{-# LANGUAGE TemplateHaskell #-}
module Hyper.TH.Traversable
( makeHTraversable
, makeHTraversableAndFoldable
, makeHTraversableAndBases
, makeHTraversableApplyAndBases
) where
import qualified Control.Lens as Lens
import Hyper.Class.Traversable (HTraversable(..), ContainedH(..))
import Hyper.TH.Apply (makeHApplicativeBases)
import Hyper.TH.Foldable (makeHFoldable)
import Hyper.TH.Functor (makeHFunctor)
import Hyper.TH.Internal.Utils
import Hyper.TH.Nodes (makeHNodes)
import Language.Haskell.TH
import Language.Haskell.TH.Datatype (ConstructorVariant)
import Hyper.Internal.Prelude
makeHTraversableApplyAndBases :: Name -> DecsQ
makeHTraversableApplyAndBases :: Name -> DecsQ
makeHTraversableApplyAndBases Name
x =
[DecsQ] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
[ Name -> DecsQ
makeHApplicativeBases Name
x
, Name -> DecsQ
makeHTraversableAndFoldable Name
x
] Q [[Dec]] -> ([[Dec]] -> [Dec]) -> DecsQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
makeHTraversableAndBases :: Name -> DecsQ
makeHTraversableAndBases :: Name -> DecsQ
makeHTraversableAndBases Name
x =
[DecsQ] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
[ Name -> DecsQ
makeHNodes Name
x
, Name -> DecsQ
makeHFunctor Name
x
, Name -> DecsQ
makeHTraversableAndFoldable Name
x
] Q [[Dec]] -> ([[Dec]] -> [Dec]) -> DecsQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
makeHTraversableAndFoldable :: Name -> DecsQ
makeHTraversableAndFoldable :: Name -> DecsQ
makeHTraversableAndFoldable Name
x =
[DecsQ] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
[ Name -> DecsQ
makeHFoldable Name
x
, Name -> DecsQ
makeHTraversable Name
x
] Q [[Dec]] -> ([[Dec]] -> [Dec]) -> DecsQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
makeHTraversable :: Name -> DecsQ
makeHTraversable :: Name -> DecsQ
makeHTraversable 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
makeHTraversableForType
makeHTraversableForType :: TypeInfo -> DecsQ
makeHTraversableForType :: TypeInfo -> DecsQ
makeHTraversableForType TypeInfo
info =
CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD (TypeInfo -> CxtQ
makeContext TypeInfo
info CxtQ -> ([Pred] -> CxtQ) -> CxtQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Pred] -> CxtQ
simplifyContext) [t|HTraversable $(pure (tiInstance info))|]
[ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'hsequence 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 'hsequence (TypeInfo
-> [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
tiConstructors TypeInfo
info [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
-> ((Name, ConstructorVariant, [Either Pred CtrTypePattern])
-> ClauseQ)
-> [ClauseQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Name, ConstructorVariant, [Either Pred CtrTypePattern]) -> ClauseQ
makeCons)
]
DecQ -> (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 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] -> Q [[Pred]]) -> Q [[Pred]]
forall a b. a -> (a -> b) -> b
& (CtrTypePattern -> CxtQ) -> [CtrTypePattern] -> Q [[Pred]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse CtrTypePattern -> CxtQ
ctxForPat Q [[Pred]] -> ([[Pred]] -> [Pred]) -> CxtQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [[Pred]] -> [Pred]
forall a. Monoid a => [a] -> a
mconcat
where
ctxForPat :: CtrTypePattern -> CxtQ
ctxForPat (InContainer Pred
t CtrTypePattern
pat) = (:) (Pred -> [Pred] -> [Pred]) -> TypeQ -> Q ([Pred] -> [Pred])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Traversable $(pure t)|] Q ([Pred] -> [Pred]) -> CxtQ -> CxtQ
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CtrTypePattern -> CxtQ
ctxForPat CtrTypePattern
pat
ctxForPat (GenEmbed Pred
t) = [t|HTraversable $(pure t)|] TypeQ -> (Pred -> [Pred]) -> CxtQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Pred -> [Pred] -> [Pred]
forall a. a -> [a] -> [a]
:[])
ctxForPat (FlatEmbed TypeInfo
t) = TypeInfo -> CxtQ
makeContext TypeInfo
t
ctxForPat CtrTypePattern
_ = [Pred] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
makeCons ::
(Name, ConstructorVariant, [Either Type CtrTypePattern]) -> ClauseQ
makeCons :: (Name, ConstructorVariant, [Either Pred CtrTypePattern]) -> ClauseQ
makeCons (Name
cName, ConstructorVariant
_, [Either Pred CtrTypePattern]
cFields) =
[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> [(Either Pred CtrTypePattern, Name)] -> PatQ
forall a. Name -> [(a, Name)] -> PatQ
consPat Name
cName [(Either Pred CtrTypePattern, Name)]
consVars] BodyQ
body []
where
body :: BodyQ
body =
[(Either Pred CtrTypePattern, Name)]
consVars [(Either Pred CtrTypePattern, Name)]
-> ((Either Pred CtrTypePattern, Name) -> ExpQ) -> [ExpQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Either Pred CtrTypePattern, Name) -> ExpQ
forall a. (Either a CtrTypePattern, Name) -> ExpQ
f
[ExpQ] -> ([ExpQ] -> ExpQ) -> ExpQ
forall a b. a -> (a -> b) -> b
& ExpQ -> [ExpQ] -> ExpQ
applicativeStyle (Name -> ExpQ
conE Name
cName)
ExpQ -> (ExpQ -> BodyQ) -> BodyQ
forall a b. a -> (a -> b) -> b
& ExpQ -> BodyQ
normalB
consVars :: [(Either Pred CtrTypePattern, Name)]
consVars = String
-> [Either Pred CtrTypePattern]
-> [(Either Pred CtrTypePattern, Name)]
forall a. String -> [a] -> [(a, Name)]
makeConstructorVars String
"x" [Either Pred CtrTypePattern]
cFields
f :: (Either a CtrTypePattern, Name) -> ExpQ
f (Either a CtrTypePattern
pat, Name
name) = Either a CtrTypePattern -> ExpQ
forall a. Either a CtrTypePattern -> ExpQ
bodyFor Either a CtrTypePattern
pat ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
name
bodyFor :: Either a CtrTypePattern -> ExpQ
bodyFor (Right CtrTypePattern
x) = CtrTypePattern -> ExpQ
bodyForPat CtrTypePattern
x
bodyFor Left{} = [|pure|]
bodyForPat :: CtrTypePattern -> ExpQ
bodyForPat Node{} = [|runContainedH|]
bodyForPat FlatEmbed{} = [|hsequence|]
bodyForPat GenEmbed{} = [|hsequence|]
bodyForPat (InContainer Pred
_ CtrTypePattern
pat) = [|traverse $(bodyForPat pat)|]