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

-- | 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 =
    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

-- | Generate an instance of 'HApply'
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 []