{-# LANGUAGE CPP #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Generics.Product.Subtype
(
Subtype (..)
) where
import Data.Generics.Internal.Families
import Data.Generics.Internal.VL.Lens as VL
import Data.Generics.Internal.Void
import Data.Generics.Product.Internal.Subtype
import GHC.Generics (Generic (Rep, to, from) )
import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
import Data.Kind (Type, Constraint)
import Data.Generics.Internal.Profunctor.Lens hiding (set)
import Data.Generics.Internal.Errors
class Subtype sup sub where
super :: VL.Lens sub sub sup sup
super
= (sub -> sup) -> ((sub, sup) -> sub) -> Lens sub sub sup sup
forall s a b t. (s -> a) -> ((s, b) -> t) -> Lens s t a b
VL.lens sub -> sup
forall sup sub. Subtype sup sub => sub -> sup
upcast ((sup -> sub -> sub) -> (sup, sub) -> sub
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry sup -> sub -> sub
forall sup sub. Subtype sup sub => sup -> sub -> sub
smash ((sup, sub) -> sub)
-> ((sub, sup) -> (sup, sub)) -> (sub, sup) -> sub
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (sub, sup) -> (sup, sub)
forall a b. (a, b) -> (b, a)
swap)
upcast :: sub -> sup
upcast s :: sub
s = sub
s sub -> ((sup -> Const sup sup) -> sub -> Const sup sub) -> sup
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall sub. Subtype sup sub => Lens sub sub sup sup
forall sup sub. Subtype sup sub => Lens sub sub sup sup
super @sup
smash :: sup -> sub -> sub
smash = Lens sub sub sup sup -> sup -> sub -> sub
forall s t a b. Lens s t a b -> b -> s -> t
VL.set (forall sub. Subtype sup sub => Lens sub sub sup sup
forall sup sub. Subtype sup sub => Lens sub sub sup sup
super @sup)
{-# MINIMAL super | smash, upcast #-}
instance
( Generic a
, Generic b
, GSmash (Rep a) (Rep b)
, GUpcast (Rep a) (Rep b)
, CustomError a b
) => Subtype b a where
smash :: b -> a -> a
smash p :: b
p b :: a
b = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> Rep a Any -> a
forall a b. (a -> b) -> a -> b
$ Rep b Any -> Rep a Any -> Rep a Any
forall k (sub :: k -> *) (sup :: k -> *) (p :: k).
GSmash sub sup =>
sup p -> sub p -> sub p
gsmash (b -> Rep b Any
forall a x. Generic a => a -> Rep a x
from b
p) (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
b)
upcast :: a -> b
upcast = Rep b Any -> b
forall a x. Generic a => Rep a x -> a
to (Rep b Any -> b) -> (a -> Rep b Any) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a Any -> Rep b Any
forall (sub :: * -> *) (sup :: * -> *) p.
GUpcast sub sup =>
sub p -> sup p
gupcast (Rep a Any -> Rep b Any) -> (a -> Rep a Any) -> a -> Rep b Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from
type family CustomError a b :: Constraint where
CustomError a b =
( ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))
, Defined (Rep a)
(NoGeneric a '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b
, 'Text "as a supertype of " ':<>: QuoteType a
])
(() :: Constraint)
, Defined (Rep b)
(NoGeneric b '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b
, 'Text "as a supertype of " ':<>: QuoteType a
])
(() :: Constraint)
)
instance {-# OVERLAPPING #-} Subtype a a where
super :: (a -> f a) -> a -> f a
super = (a -> f a) -> a -> f a
forall a. a -> a
id
#if __GLASGOW_HASKELL__ < 804
#else
#endif
instance {-# OVERLAPPING #-} Subtype a Void where
super :: (a -> f a) -> Void -> f Void
super = (a -> f a) -> Void -> f Void
forall a. HasCallStack => a
undefined
#if __GLASGOW_HASKELL__ < 804
#else
#endif
instance {-# OVERLAPPING #-} Subtype Void a where
super :: (Void -> f Void) -> a -> f a
super = (Void -> f Void) -> a -> f a
forall a. HasCallStack => a
undefined
type family ErrorUnless (sup :: Type) (sub :: Type) (diff :: [Symbol]) :: Constraint where
ErrorUnless _ _ '[]
= ()
ErrorUnless sup sub fs
= TypeError
( 'Text "The type '"
':<>: 'ShowType sub
':<>: 'Text "' is not a subtype of '"
':<>: 'ShowType sup ':<>: 'Text "'."
':$$: 'Text "The following fields are missing from '"
':<>: 'ShowType sub ':<>: 'Text "':"
':$$: ShowSymbols fs
)