{-# LANGUAGE TemplateHaskell #-}

-- | Generate 'HPointed' instances via @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

-- | Generate a 'HPointed' instance
makeHPointed :: Name -> DecsQ
makeHPointed :: Name -> DecsQ
makeHPointed Name
typeName = Name -> Q TypeInfo
makeTypeInfo Name
typeName 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] -> 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
"makeHPointed only supports types with a single constructor"
        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|HPointed $(pure (tiInstance info))|]
            [ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'hpure 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 'hpure [TypeInfo
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Q Clause
makeHPureCtr TypeInfo
info (Name, ConstructorVariant, [Either Type CtrTypePattern])
cons]
            ]
        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 (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|Monoid $(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|HPointed $(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 []

makeHPureCtr :: TypeInfo -> (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> Q Clause
makeHPureCtr :: TypeInfo
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Q Clause
makeHPureCtr TypeInfo
typeInfo (Name
cName, ConstructorVariant
_, [Either Type CtrTypePattern]
cFields) =
    forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
varF] (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
cName) ([Either Type CtrTypePattern]
cFields forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Either Type CtrTypePattern -> Q Exp
bodyFor))) []
    where
        bodyFor :: Either Type CtrTypePattern -> Q Exp
bodyFor (Right CtrTypePattern
x) = CtrTypePattern -> Q Exp
bodyForPat CtrTypePattern
x
        bodyFor Left{} = [|mempty|]
        f :: Q Exp
f = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
varF
        bodyForPat :: CtrTypePattern -> Q Exp
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 forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Either Type CtrTypePattern -> Q Exp
bodyFor forall a b. a -> (a -> b) -> b
& 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
iName)
                [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
_ -> 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