{-# 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 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