{-# LANGUAGE TemplateHaskell #-}
module Hyper.TH.Apply
( makeHApply
, makeHApplyAndBases
, makeHApplicativeBases
) where
import Control.Applicative (liftA2)
import qualified Control.Lens as Lens
import Hyper.Class.Apply (HApply (..))
import Hyper.TH.Functor (makeHFunctor)
import Hyper.TH.Internal.Utils
import Hyper.TH.Nodes (makeHNodes)
import Hyper.TH.Pointed (makeHPointed)
import Language.Haskell.TH
import Hyper.Internal.Prelude
makeHApplicativeBases :: Name -> DecsQ
makeHApplicativeBases :: Name -> DecsQ
makeHApplicativeBases Name
x =
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
[ Name -> DecsQ
makeHPointed Name
x
, Name -> DecsQ
makeHApplyAndBases Name
x
]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
makeHApplyAndBases :: Name -> DecsQ
makeHApplyAndBases :: Name -> DecsQ
makeHApplyAndBases 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
makeHApply Name
x
]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
makeHApply :: Name -> DecsQ
makeHApply :: Name -> DecsQ
makeHApply Name
typeName = Name -> Q TypeInfo
makeTypeInfo Name
typeName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeInfo -> DecsQ
makeHApplyForType
makeHApplyForType :: TypeInfo -> DecsQ
makeHApplyForType :: TypeInfo -> DecsQ
makeHApplyForType TypeInfo
info =
do
(Name
name, ConstructorVariant
_, [Either Type CtrTypePattern]
fields) <-
case TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
info of
[(Name, ConstructorVariant, [Either Type CtrTypePattern])
x] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name, ConstructorVariant, [Either Type CtrTypePattern])
x
[(Name, ConstructorVariant, [Either Type CtrTypePattern])]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeHApply only supports types with a single constructor"
let xVars :: [(Either Type CtrTypePattern, Name)]
xVars = forall a. String -> [a] -> [(a, Name)]
makeConstructorVars String
"x" [Either Type CtrTypePattern]
fields
let yVars :: [(Either Type CtrTypePattern, Name)]
yVars = forall a. String -> [a] -> [(a, Name)]
makeConstructorVars String
"y" [Either Type CtrTypePattern]
fields
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|HApply $(pure (tiInstance info))|]
[ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'hzip 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
'hzip
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
[ forall a. Name -> [(a, Name)] -> Q Pat
consPat Name
name [(Either Type CtrTypePattern, Name)]
xVars
, forall a. Name -> [(a, Name)] -> Q Pat
consPat Name
name [(Either Type CtrTypePattern, Name)]
yVars
]
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name) (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {m :: * -> *} {a} {a}.
Quote m =>
(Either a CtrTypePattern, Name) -> (a, Name) -> m Exp
f [(Either Type CtrTypePattern, Name)]
xVars [(Either Type CtrTypePattern, Name)]
yVars)))
[]
]
]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall a. a -> [a] -> [a]
: [])
where
bodyFor :: Either a CtrTypePattern -> m Exp
bodyFor (Right CtrTypePattern
x) = forall {m :: * -> *}. Quote m => CtrTypePattern -> m Exp
bodyForPat CtrTypePattern
x
bodyFor Left{} = [|(<>)|]
bodyForPat :: CtrTypePattern -> m Exp
bodyForPat Node{} = [|(:*:)|]
bodyForPat GenEmbed{} = [|hzip|]
bodyForPat FlatEmbed{} = [|hzip|]
bodyForPat (InContainer Type
_ CtrTypePattern
pat) = [|liftA2 $(bodyForPat pat)|]
f :: (Either a CtrTypePattern, Name) -> (a, Name) -> m Exp
f (Either a CtrTypePattern
p, Name
x) (a
_, Name
y) = [|$(bodyFor p) $(varE x) $(varE y)|]
makeContext :: TypeInfo -> Q [Pred]
makeContext :: TypeInfo -> Q [Type]
makeContext TypeInfo
info =
TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
info forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall s a. s -> Getting a s a -> a
^. forall s t a b. Field3 s t a b => Lens s t a b
Lens._3) 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 Either Type CtrTypePattern -> Q [Type]
ctxFor forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. Monoid a => [a] -> a
mconcat
where
ctxFor :: Either Type CtrTypePattern -> Q [Type]
ctxFor (Right CtrTypePattern
x) = CtrTypePattern -> Q [Type]
ctxForPat CtrTypePattern
x
ctxFor (Left Type
x) = [t|Semigroup $(pure x)|] forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall a. a -> [a] -> [a]
: [])
ctxForPat :: CtrTypePattern -> Q [Type]
ctxForPat (InContainer Type
t CtrTypePattern
pat) = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Applicative $(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|HApply $(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 []