{-# LANGUAGE TemplateHaskell #-}
module Hyper.TH.Pointed
( makeHPointed
) where
import qualified Control.Lens as Lens
import Hyper.Class.Pointed (HPointed(..))
import Hyper.TH.Internal.Utils
import Language.Haskell.TH
import Language.Haskell.TH.Datatype (ConstructorVariant)
import Hyper.Internal.Prelude
makeHPointed :: Name -> DecsQ
makeHPointed :: Name -> DecsQ
makeHPointed 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
makeHPointedForType
makeHPointedForType :: TypeInfo -> DecsQ
makeHPointedForType :: TypeInfo -> DecsQ
makeHPointedForType TypeInfo
info =
do
(Name, ConstructorVariant, [Either Type CtrTypePattern])
cons <-
case TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
info of
[(Name, ConstructorVariant, [Either Type CtrTypePattern])
x] -> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Q (Name, ConstructorVariant, [Either Type CtrTypePattern])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name, ConstructorVariant, [Either Type CtrTypePattern])
x
[(Name, ConstructorVariant, [Either Type CtrTypePattern])]
_ -> String
-> Q (Name, ConstructorVariant, [Either Type CtrTypePattern])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeHPointed only supports types with a single constructor"
CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD (TypeInfo -> CxtQ
makeContext TypeInfo
info CxtQ -> ([Type] -> CxtQ) -> CxtQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Type] -> CxtQ
simplifyContext) [t|HPointed $(pure (tiInstance info))|]
[ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'hpure Inline
Inline RuleMatch
FunLike Phases
AllPhases Pragma -> (Pragma -> Dec) -> Dec
forall a b. a -> (a -> b) -> b
& Pragma -> Dec
PragmaD Dec -> (Dec -> Q Dec) -> Q Dec
forall a b. a -> (a -> b) -> b
& Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure
, Name -> [ClauseQ] -> Q Dec
funD 'hpure [TypeInfo
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> ClauseQ
makeHPureCtr TypeInfo
info (Name, ConstructorVariant, [Either Type CtrTypePattern])
cons]
]
Q Dec -> (Dec -> [Dec]) -> DecsQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[])
makeContext :: TypeInfo -> Q [Pred]
makeContext :: TypeInfo -> CxtQ
makeContext TypeInfo
info =
TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
info [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
-> ((Name, ConstructorVariant, [Either Type CtrTypePattern])
-> [Either Type CtrTypePattern])
-> [Either Type CtrTypePattern]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Getting
[Either Type CtrTypePattern]
(Name, ConstructorVariant, [Either Type CtrTypePattern])
[Either Type CtrTypePattern]
-> [Either Type CtrTypePattern]
forall s a. s -> Getting a s a -> a
^. Getting
[Either Type CtrTypePattern]
(Name, ConstructorVariant, [Either Type CtrTypePattern])
[Either Type CtrTypePattern]
forall s t a b. Field3 s t a b => Lens s t a b
Lens._3) [Either Type CtrTypePattern]
-> ([Either Type CtrTypePattern] -> Q [[Type]]) -> Q [[Type]]
forall a b. a -> (a -> b) -> b
& (Either Type CtrTypePattern -> CxtQ)
-> [Either Type CtrTypePattern] -> Q [[Type]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Either Type CtrTypePattern -> CxtQ
ctxFor Q [[Type]] -> ([[Type]] -> [Type]) -> CxtQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [[Type]] -> [Type]
forall a. Monoid a => [a] -> a
mconcat
where
ctxFor :: Either Type CtrTypePattern -> CxtQ
ctxFor (Right CtrTypePattern
x) = CtrTypePattern -> CxtQ
ctxForPat CtrTypePattern
x
ctxFor (Left Type
x) = [t|Monoid $(pure x)|] TypeQ -> (Type -> [Type]) -> CxtQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[])
ctxForPat :: CtrTypePattern -> CxtQ
ctxForPat (InContainer Type
t CtrTypePattern
pat) = (:) (Type -> [Type] -> [Type]) -> TypeQ -> Q ([Type] -> [Type])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Applicative $(pure t)|] Q ([Type] -> [Type]) -> CxtQ -> CxtQ
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CtrTypePattern -> CxtQ
ctxForPat CtrTypePattern
pat
ctxForPat (GenEmbed Type
t) = [t|HPointed $(pure t)|] TypeQ -> (Type -> [Type]) -> CxtQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[])
ctxForPat (FlatEmbed TypeInfo
t) = TypeInfo -> CxtQ
makeContext TypeInfo
t
ctxForPat CtrTypePattern
_ = [Type] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
makeHPureCtr :: TypeInfo -> (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> Q Clause
makeHPureCtr :: TypeInfo
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> ClauseQ
makeHPureCtr TypeInfo
typeInfo (Name
cName, ConstructorVariant
_, [Either Type CtrTypePattern]
cFields) =
[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
varF] (ExpQ -> BodyQ
normalB ((ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
cName) ([Either Type CtrTypePattern]
cFields [Either Type CtrTypePattern]
-> (Either Type CtrTypePattern -> ExpQ) -> [ExpQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Either Type CtrTypePattern -> ExpQ
bodyFor))) []
where
bodyFor :: Either Type CtrTypePattern -> ExpQ
bodyFor (Right CtrTypePattern
x) = CtrTypePattern -> ExpQ
bodyForPat CtrTypePattern
x
bodyFor Left{} = [|mempty|]
f :: ExpQ
f = Name -> ExpQ
varE Name
varF
bodyForPat :: CtrTypePattern -> ExpQ
bodyForPat (Node Type
t) = [|$f $(nodeWit wit t)|]
bodyForPat (FlatEmbed TypeInfo
inner) =
case TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
inner of
[(Name
iName, ConstructorVariant
_, [Either Type CtrTypePattern]
iFields)] -> [Either Type CtrTypePattern]
iFields [Either Type CtrTypePattern]
-> (Either Type CtrTypePattern -> ExpQ) -> [ExpQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Either Type CtrTypePattern -> ExpQ
bodyFor [ExpQ] -> ([ExpQ] -> ExpQ) -> ExpQ
forall a b. a -> (a -> b) -> b
& (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
iName)
[(Name, ConstructorVariant, [Either Type CtrTypePattern])]
_ -> String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeHPointed only supports embedded types with a single constructor"
bodyForPat (GenEmbed Type
t) = [|hpure ($f . $(embedWit wit t))|]
bodyForPat (InContainer Type
_ CtrTypePattern
pat) = [|pure $(bodyForPat pat)|]
varF :: Name
varF = String -> Name
mkName String
"_f"
([Type -> Q Con]
_, NodeWitnesses
wit) = TypeInfo -> ([Type -> Q Con], NodeWitnesses)
makeNodeOf TypeInfo
typeInfo