{-# LANGUAGE TemplateHaskell #-}

-- | Generate 'HApply' and related instances via @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

-- | Generate instances of 'HApply',
-- 'Hyper.Class.Functor.HFunctor', 'Hyper.Class.Pointed.HPointed' and 'Hyper.Class.Nodes.HNodes',
-- which together form 'HApplicative'.
makeHApplicativeBases :: Name -> DecsQ
makeHApplicativeBases :: Name -> DecsQ
makeHApplicativeBases Name
x =
    [DecsQ] -> Q [[Dec]]
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
    ] 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

-- | Generate an instance of 'HApply'
-- along with its bases 'Hyper.Class.Functor.HFunctor' and 'Hyper.Class.Nodes.HNodes'
makeHApplyAndBases :: Name -> DecsQ
makeHApplyAndBases :: Name -> DecsQ
makeHApplyAndBases 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
makeHApply 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

-- | Generate an instance of 'HApply'
makeHApply :: Name -> DecsQ
makeHApply :: Name -> DecsQ
makeHApply 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
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] -> (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
"makeHApply only supports types with a single constructor"
        let xVars :: [(Either Type CtrTypePattern, Name)]
xVars = String
-> [Either Type CtrTypePattern]
-> [(Either Type CtrTypePattern, Name)]
forall a. String -> [a] -> [(a, Name)]
makeConstructorVars String
"x" [Either Type CtrTypePattern]
fields
        let yVars :: [(Either Type CtrTypePattern, Name)]
yVars = String
-> [Either Type CtrTypePattern]
-> [(Either Type CtrTypePattern, Name)]
forall a. String -> [a] -> [(a, Name)]
makeConstructorVars String
"y" [Either Type CtrTypePattern]
fields
        CxtQ -> TypeQ -> [DecQ] -> DecQ
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|HApply $(pure (tiInstance info))|]
            [ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'hzip 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 'hzip
                [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
                    [ Name -> [(Either Type CtrTypePattern, Name)] -> PatQ
forall a. Name -> [(a, Name)] -> PatQ
consPat Name
name [(Either Type CtrTypePattern, Name)]
xVars
                    , Name -> [(Either Type CtrTypePattern, Name)] -> PatQ
forall a. Name -> [(a, Name)] -> PatQ
consPat Name
name [(Either Type CtrTypePattern, Name)]
yVars
                    ] (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
name) (((Either Type CtrTypePattern, Name)
 -> (Either Type CtrTypePattern, Name) -> ExpQ)
-> [(Either Type CtrTypePattern, Name)]
-> [(Either Type CtrTypePattern, Name)]
-> [ExpQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Either Type CtrTypePattern, Name)
-> (Either Type CtrTypePattern, Name) -> ExpQ
forall a a. (Either a CtrTypePattern, Name) -> (a, Name) -> ExpQ
f [(Either Type CtrTypePattern, Name)]
xVars [(Either Type CtrTypePattern, Name)]
yVars))) []
                ]
            ]
            DecQ -> (Dec -> [Dec]) -> DecsQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[])
    where
        bodyFor :: Either a CtrTypePattern -> ExpQ
bodyFor (Right CtrTypePattern
x) = CtrTypePattern -> ExpQ
bodyForPat CtrTypePattern
x
        bodyFor Left{} = [|(<>)|]
        bodyForPat :: CtrTypePattern -> ExpQ
bodyForPat Node{} = [|(:*:)|]
        bodyForPat GenEmbed{} = [|hzip|]
        bodyForPat FlatEmbed{} = [|hzip|]
        bodyForPat (InContainer Type
_ CtrTypePattern
pat) = [|liftA2 $(bodyForPat pat)|]
        f :: (Either a CtrTypePattern, Name) -> (a, Name) -> ExpQ
f (Either a CtrTypePattern
p, Name
x) (a
_, Name
y) = [|$(bodyFor p) $(varE x) $(varE y)|]

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|Semigroup $(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|HApply $(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 []