{-# LANGUAGE TemplateHaskell #-}
module Hyper.TH.Traversable
( makeHTraversable
, makeHTraversableAndFoldable
, makeHTraversableAndBases
, makeHTraversableApplyAndBases
) where
import qualified Control.Lens as Lens
import Hyper.Class.Traversable (ContainedH (..), HTraversable (..))
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 =
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
]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
makeHTraversableAndBases :: Name -> DecsQ
makeHTraversableAndBases :: Name -> DecsQ
makeHTraversableAndBases Name
x =
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
]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
makeHTraversableAndFoldable :: Name -> DecsQ
makeHTraversableAndFoldable :: Name -> DecsQ
makeHTraversableAndFoldable Name
x =
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
]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
makeHTraversable :: Name -> DecsQ
makeHTraversable :: Name -> DecsQ
makeHTraversable Name
typeName = Name -> Q TypeInfo
makeTypeInfo Name
typeName 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 =
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD
(TypeInfo -> Q [Type]
makeContext TypeInfo
info forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Type] -> Q [Type]
simplifyContext)
[t|HTraversable $(pure (tiInstance info))|]
[ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'hsequence Inline
Inline RuleMatch
FunLike Phases
AllPhases forall a b. a -> (a -> b) -> b
& Pragma -> Dec
PragmaD forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a. Applicative f => a -> f a
pure
, forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'hsequence (TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
info forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Q Clause
makeCons)
]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall a. a -> [a] -> [a]
: [])
makeContext :: TypeInfo -> Q [Pred]
makeContext :: TypeInfo -> Q [Type]
makeContext TypeInfo
info =
TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
info forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field3 s t a b => Lens s t a b
Lens._3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a b. Prism (Either c a) (Either c b) a b
Lens._Right
forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse CtrTypePattern -> Q [Type]
ctxForPat
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. Monoid a => [a] -> a
mconcat
where
ctxForPat :: CtrTypePattern -> Q [Type]
ctxForPat (InContainer Type
t CtrTypePattern
pat) = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Traversable $(pure t)|] forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CtrTypePattern -> Q [Type]
ctxForPat CtrTypePattern
pat
ctxForPat (GenEmbed Type
t) = [t|HTraversable $(pure t)|] forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall a. a -> [a] -> [a]
: [])
ctxForPat (FlatEmbed TypeInfo
t) = TypeInfo -> Q [Type]
makeContext TypeInfo
t
ctxForPat CtrTypePattern
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
makeCons ::
(Name, ConstructorVariant, [Either Type CtrTypePattern]) -> ClauseQ
makeCons :: (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Q Clause
makeCons (Name
cName, ConstructorVariant
_, [Either Type CtrTypePattern]
cFields) =
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall a. Name -> [(a, Name)] -> Q Pat
consPat Name
cName [(Either Type CtrTypePattern, Name)]
consVars] Q Body
body []
where
body :: Q Body
body =
[(Either Type CtrTypePattern, Name)]
consVars
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall {m :: * -> *} {a}.
Quote m =>
(Either a CtrTypePattern, Name) -> m Exp
f
forall a b. a -> (a -> b) -> b
& Q Exp -> [Q Exp] -> Q Exp
applicativeStyle (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cName)
forall a b. a -> (a -> b) -> b
& forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
consVars :: [(Either Type CtrTypePattern, Name)]
consVars = forall a. String -> [a] -> [(a, Name)]
makeConstructorVars String
"x" [Either Type CtrTypePattern]
cFields
f :: (Either a CtrTypePattern, Name) -> m Exp
f (Either a CtrTypePattern
pat, Name
name) = forall {m :: * -> *} {a}.
Quote m =>
Either a CtrTypePattern -> m Exp
bodyFor Either a CtrTypePattern
pat forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name
bodyFor :: Either a CtrTypePattern -> m Exp
bodyFor (Right CtrTypePattern
x) = forall {m :: * -> *}. Quote m => CtrTypePattern -> m Exp
bodyForPat CtrTypePattern
x
bodyFor Left{} = [|pure|]
bodyForPat :: CtrTypePattern -> m Exp
bodyForPat Node{} = [|runContainedH|]
bodyForPat FlatEmbed{} = [|hsequence|]
bodyForPat GenEmbed{} = [|hsequence|]
bodyForPat (InContainer Type
_ CtrTypePattern
pat) = [|traverse $(bodyForPat pat)|]