{-# LANGUAGE TemplateHaskell, EmptyCase #-}
module Hyper.TH.Nodes
( makeHNodes
) where
import qualified Control.Lens as Lens
import GHC.Generics (V1)
import Hyper.Class.Nodes (HNodes(..), HWitness(..))
import Hyper.TH.Internal.Utils
import Language.Haskell.TH
import qualified Language.Haskell.TH.Datatype as D
import Hyper.Internal.Prelude
makeHNodes :: Name -> DecsQ
makeHNodes :: Name -> DecsQ
makeHNodes Name
typeName = Name -> Q TypeInfo
makeTypeInfo Name
typeName Q TypeInfo -> (TypeInfo -> DecsQ) -> DecsQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeInfo -> DecsQ
makeHNodesForType
makeHNodesForType :: TypeInfo -> DecsQ
makeHNodesForType :: TypeInfo -> DecsQ
makeHNodesForType TypeInfo
info =
[ CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([Pred] -> CxtQ
simplifyContext (TypeInfo -> [Pred]
makeContext TypeInfo
info)) [t|HNodes $(pure (tiInstance info))|]
[ Name -> Maybe [Q TyVarBndrUnit] -> [TypeQ] -> TypeQ -> DecQ
D.tySynInstDCompat
''HNodesConstraint
([Q TyVarBndrUnit] -> Maybe [Q TyVarBndrUnit]
forall a. a -> Maybe a
Just [TyVarBndrUnit -> Q TyVarBndrUnit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> TyVarBndrUnit
PlainTV Name
constraintVar)])
[Pred -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo -> Pred
tiInstance TypeInfo
info), TypeQ
c]
(CxtQ
nodesConstraint CxtQ -> ([Pred] -> CxtQ) -> CxtQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Pred] -> CxtQ
simplifyContext CxtQ -> ([Pred] -> Pred) -> TypeQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [Pred] -> Pred
forall (t :: * -> *). Foldable t => t Pred -> Pred
toTuple)
, Name -> Maybe [Q TyVarBndrUnit] -> [TypeQ] -> TypeQ -> DecQ
D.tySynInstDCompat ''HWitnessType Maybe [Q TyVarBndrUnit]
forall a. Maybe a
Nothing [Pred -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo -> Pred
tiInstance TypeInfo
info)] TypeQ
witType
, Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'hLiftConstraint Inline
Inline RuleMatch
FunLike Phases
AllPhases Pragma -> (Pragma -> Dec) -> Dec
forall a b. a -> (a -> b) -> b
& Pragma -> Dec
PragmaD Dec -> (Dec -> DecQ) -> DecQ
forall a b. a -> (a -> b) -> b
& Dec -> DecQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure
, Name -> [ClauseQ] -> DecQ
funD 'hLiftConstraint (NodeWitnesses -> [ClauseQ]
makeHLiftConstraints NodeWitnesses
wit)
]
] [DecQ] -> [DecQ] -> [DecQ]
forall a. Semigroup a => a -> a -> a
<> [DecQ]
witDecs
[DecQ] -> ([DecQ] -> DecsQ) -> DecsQ
forall a b. a -> (a -> b) -> b
& [DecQ] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
where
(TypeQ
witType, [DecQ]
witDecs)
| [Pred -> Q Con] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pred -> Q Con]
nodeOfCons = ([t|V1|], [])
| Bool
otherwise =
( TypeInfo -> [TyVarBndrUnit]
tiParams TypeInfo
info [TyVarBndrUnit] -> (TyVarBndrUnit -> TypeQ) -> [TypeQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Name -> TypeQ
varT (Name -> TypeQ)
-> (TyVarBndrUnit -> Name) -> TyVarBndrUnit -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndrUnit -> Name
forall flag. TyVarBndrUnit -> Name
D.tvName [TypeQ] -> ([TypeQ] -> TypeQ) -> TypeQ
forall a b. a -> (a -> b) -> b
& (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT Name
witTypeName)
, [CxtQ
-> Name
-> [TyVarBndrUnit]
-> Maybe Pred
-> [Q Con]
-> [DerivClauseQ]
-> DecQ
dataD ([Pred] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) Name
witTypeName
(TypeInfo -> [TyVarBndrUnit]
tiParams TypeInfo
info [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. Semigroup a => a -> a -> a
<> [Name -> TyVarBndrUnit
PlainTV (String -> Name
mkName String
"node")])
Maybe Pred
forall a. Maybe a
Nothing ([Pred -> Q Con]
nodeOfCons [Pred -> Q Con] -> ((Pred -> Q Con) -> Q Con) -> [Q Con]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (TypeQ
witType TypeQ -> (Pred -> Q Con) -> Q Con
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)) []
]
)
where
witTypeName :: Name
witTypeName = String -> Name
mkName (String
"W_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
niceName (TypeInfo -> Name
tiName TypeInfo
info))
([Pred -> Q Con]
nodeOfCons, NodeWitnesses
wit) = TypeInfo -> ([Pred -> Q Con], NodeWitnesses)
makeNodeOf TypeInfo
info
constraintVar :: Name
constraintVar = String -> Name
mkName String
"constraint"
c :: TypeQ
c = Name -> TypeQ
varT Name
constraintVar
contents :: TypeContents
contents = TypeInfo -> TypeContents
childrenTypes TypeInfo
info
nodesConstraint :: CxtQ
nodesConstraint =
(TypeContents -> Set Pred
tcChildren TypeContents
contents Set Pred -> Getting (Endo [Pred]) (Set Pred) Pred -> [Pred]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Pred]) (Set Pred) Pred
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
Lens.folded [Pred] -> (Pred -> TypeQ) -> [TypeQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (TypeQ
c TypeQ -> TypeQ -> TypeQ
`appT`) (TypeQ -> TypeQ) -> (Pred -> TypeQ) -> Pred -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pred -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
[TypeQ] -> [TypeQ] -> [TypeQ]
forall a. Semigroup a => a -> a -> a
<> (TypeContents -> Set Pred
tcEmbeds TypeContents
contents Set Pred -> Getting (Endo [Pred]) (Set Pred) Pred -> [Pred]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Pred]) (Set Pred) Pred
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
Lens.folded [Pred] -> (Pred -> TypeQ) -> [TypeQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Pred
x -> [t|HNodesConstraint $(pure x) $c|])
[TypeQ] -> [TypeQ] -> [TypeQ]
forall a. Semigroup a => a -> a -> a
<> (TypeContents -> Set Pred
tcOthers TypeContents
contents Set Pred -> Getting (Endo [Pred]) (Set Pred) Pred -> [Pred]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Pred]) (Set Pred) Pred
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
Lens.folded [Pred] -> (Pred -> TypeQ) -> [TypeQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Pred -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
[TypeQ] -> ([TypeQ] -> CxtQ) -> CxtQ
forall a b. a -> (a -> b) -> b
& [TypeQ] -> CxtQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
makeContext :: TypeInfo -> [Pred]
makeContext :: TypeInfo -> [Pred]
makeContext TypeInfo
info =
TypeInfo
-> [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
tiConstructors TypeInfo
info [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
-> Getting
(Endo [CtrTypePattern])
[(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
CtrTypePattern
-> [CtrTypePattern]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ((Name, ConstructorVariant, [Either Pred CtrTypePattern])
-> Const
(Endo [CtrTypePattern])
(Name, ConstructorVariant, [Either Pred CtrTypePattern]))
-> [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
-> Const
(Endo [CtrTypePattern])
[(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Name, ConstructorVariant, [Either Pred CtrTypePattern])
-> Const
(Endo [CtrTypePattern])
(Name, ConstructorVariant, [Either Pred CtrTypePattern]))
-> [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
-> Const
(Endo [CtrTypePattern])
[(Name, ConstructorVariant, [Either Pred CtrTypePattern])])
-> ((CtrTypePattern
-> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> (Name, ConstructorVariant, [Either Pred CtrTypePattern])
-> Const
(Endo [CtrTypePattern])
(Name, ConstructorVariant, [Either Pred CtrTypePattern]))
-> Getting
(Endo [CtrTypePattern])
[(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
CtrTypePattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Either Pred CtrTypePattern]
-> Const (Endo [CtrTypePattern]) [Either Pred CtrTypePattern])
-> (Name, ConstructorVariant, [Either Pred CtrTypePattern])
-> Const
(Endo [CtrTypePattern])
(Name, ConstructorVariant, [Either Pred CtrTypePattern])
forall s t a b. Field3 s t a b => Lens s t a b
Lens._3 (([Either Pred CtrTypePattern]
-> Const (Endo [CtrTypePattern]) [Either Pred CtrTypePattern])
-> (Name, ConstructorVariant, [Either Pred CtrTypePattern])
-> Const
(Endo [CtrTypePattern])
(Name, ConstructorVariant, [Either Pred CtrTypePattern]))
-> ((CtrTypePattern
-> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> [Either Pred CtrTypePattern]
-> Const (Endo [CtrTypePattern]) [Either Pred CtrTypePattern])
-> (CtrTypePattern -> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> (Name, ConstructorVariant, [Either Pred CtrTypePattern])
-> Const
(Endo [CtrTypePattern])
(Name, ConstructorVariant, [Either Pred CtrTypePattern])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Pred CtrTypePattern
-> Const (Endo [CtrTypePattern]) (Either Pred CtrTypePattern))
-> [Either Pred CtrTypePattern]
-> Const (Endo [CtrTypePattern]) [Either Pred CtrTypePattern]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Either Pred CtrTypePattern
-> Const (Endo [CtrTypePattern]) (Either Pred CtrTypePattern))
-> [Either Pred CtrTypePattern]
-> Const (Endo [CtrTypePattern]) [Either Pred CtrTypePattern])
-> ((CtrTypePattern
-> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> Either Pred CtrTypePattern
-> Const (Endo [CtrTypePattern]) (Either Pred CtrTypePattern))
-> (CtrTypePattern -> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> [Either Pred CtrTypePattern]
-> Const (Endo [CtrTypePattern]) [Either Pred CtrTypePattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CtrTypePattern -> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> Either Pred CtrTypePattern
-> Const (Endo [CtrTypePattern]) (Either Pred CtrTypePattern)
forall c a b. Prism (Either c a) (Either c b) a b
Lens._Right [CtrTypePattern] -> (CtrTypePattern -> [Pred]) -> [Pred]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CtrTypePattern -> [Pred]
ctxForPat
where
ctxForPat :: CtrTypePattern -> [Pred]
ctxForPat (InContainer Pred
_ CtrTypePattern
pat) = CtrTypePattern -> [Pred]
ctxForPat CtrTypePattern
pat
ctxForPat (GenEmbed Pred
t) = [Name -> Pred
ConT ''HNodes Pred -> Pred -> Pred
`AppT` Pred
t]
ctxForPat CtrTypePattern
_ = []
makeHLiftConstraints :: NodeWitnesses -> [Q Clause]
makeHLiftConstraints :: NodeWitnesses -> [ClauseQ]
makeHLiftConstraints NodeWitnesses
wit
| [ClauseQ] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClauseQ]
clauses = [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|\case|]) []]
| Bool
otherwise = [ClauseQ]
clauses
where
clauses :: [ClauseQ]
clauses = (NodeWitnesses -> [Name]
nodeWitCtrs NodeWitnesses
wit [Name] -> (Name -> ClauseQ) -> [ClauseQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Name -> ClauseQ
liftNode) [ClauseQ] -> [ClauseQ] -> [ClauseQ]
forall a. Semigroup a => a -> a -> a
<> (NodeWitnesses -> [Name]
embedWitCtrs NodeWitnesses
wit [Name] -> (Name -> ClauseQ) -> [ClauseQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Name -> ClauseQ
liftEmbed)
liftNode :: Name -> ClauseQ
liftNode Name
x = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP 'HWitness [Name -> [PatQ] -> PatQ
conP Name
x []]] (ExpQ -> BodyQ
normalB [|const id|]) []
liftEmbed :: Name -> ClauseQ
liftEmbed Name
x =
[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP 'HWitness [Name -> [PatQ] -> PatQ
conP Name
x [Name -> PatQ
varP Name
witVar]]]
(ExpQ -> BodyQ
normalB [|hLiftConstraint $(varE witVar)|]) []
witVar :: Name
witVar :: Name
witVar = String -> Name
mkName String
"witness"