{-# LANGUAGE TemplateHaskell #-}

-- | Generate 'HTraversable' and related instances via @TemplateHaskell@
module Hyper.TH.Traversable
    ( makeHTraversable
    , makeHTraversableAndFoldable
    , makeHTraversableAndBases
    , makeHTraversableApplyAndBases
    ) where

import qualified Control.Lens as Lens
import Hyper.Class.Traversable (ContainedH (..), HTraversable (..))
import Hyper.TH.Apply (makeHApplicativeBases)
import Hyper.TH.Foldable (makeHFoldable)
import Hyper.TH.Functor (makeHFunctor)
import Hyper.TH.Internal.Utils
import Hyper.TH.Nodes (makeHNodes)
import Language.Haskell.TH
import Language.Haskell.TH.Datatype (ConstructorVariant)

import Hyper.Internal.Prelude

-- | Generate 'HTraversable' and 'Hyper.Class.Apply.HApply' instances along with all of their base classes:
-- 'Hyper.Class.Foldable.HFoldable', 'Hyper.Class.Functor.HFunctor',
-- 'Hyper.Class.Pointed.HPointed', and 'Hyper.Class.Nodes.HNodes'.
makeHTraversableApplyAndBases :: Name -> DecsQ
makeHTraversableApplyAndBases :: Name -> DecsQ
makeHTraversableApplyAndBases Name
x =
    forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
        [ Name -> DecsQ
makeHApplicativeBases Name
x
        , Name -> DecsQ
makeHTraversableAndFoldable Name
x
        ]
        forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat

-- | Generate a 'HTraversable' instance along with the instance of its base classes:
-- 'Hyper.Class.Foldable.HFoldable', 'Hyper.Class.Functor.HFunctor', and 'Hyper.Class.Nodes.HNodes'.
makeHTraversableAndBases :: Name -> DecsQ
makeHTraversableAndBases :: Name -> DecsQ
makeHTraversableAndBases 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
makeHTraversableAndFoldable Name
x
        ]
        forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat

-- | Generate 'HTraversable' and 'Hyper.Class.Foldable.HFoldable' instances
makeHTraversableAndFoldable :: Name -> DecsQ
makeHTraversableAndFoldable :: Name -> DecsQ
makeHTraversableAndFoldable Name
x =
    forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
        [ Name -> DecsQ
makeHFoldable Name
x
        , Name -> DecsQ
makeHTraversable Name
x
        ]
        forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat

-- | Generate a 'HTraversable' instance
makeHTraversable :: Name -> DecsQ
makeHTraversable :: Name -> DecsQ
makeHTraversable Name
typeName = Name -> Q TypeInfo
makeTypeInfo Name
typeName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeInfo -> DecsQ
makeHTraversableForType

makeHTraversableForType :: TypeInfo -> DecsQ
makeHTraversableForType :: TypeInfo -> DecsQ
makeHTraversableForType TypeInfo
info =
    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|HTraversable $(pure (tiInstance info))|]
        [ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'hsequence 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 'hsequence (TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
info forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Q Clause
makeCons)
        ]
        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 s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field3 s t a b => Lens s t a b
Lens._3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a b. Prism (Either c a) (Either c b) a b
Lens._Right
        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 CtrTypePattern -> Q [Type]
ctxForPat
        forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. Monoid a => [a] -> a
mconcat
    where
        ctxForPat :: CtrTypePattern -> Q [Type]
ctxForPat (InContainer Type
t CtrTypePattern
pat) = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Traversable $(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|HTraversable $(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 []

makeCons ::
    (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> ClauseQ
makeCons :: (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Q Clause
makeCons (Name
cName, ConstructorVariant
_, [Either Type CtrTypePattern]
cFields) =
    forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall a. Name -> [(a, Name)] -> Q Pat
consPat Name
cName [(Either Type CtrTypePattern, Name)]
consVars] Q Body
body []
    where
        body :: Q Body
body =
            [(Either Type CtrTypePattern, Name)]
consVars
                forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall {m :: * -> *} {a}.
Quote m =>
(Either a CtrTypePattern, Name) -> m Exp
f
                forall a b. a -> (a -> b) -> b
& Q Exp -> [Q Exp] -> Q Exp
applicativeStyle (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cName)
                forall a b. a -> (a -> b) -> b
& forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
        consVars :: [(Either Type CtrTypePattern, Name)]
consVars = forall a. String -> [a] -> [(a, Name)]
makeConstructorVars String
"x" [Either Type CtrTypePattern]
cFields
        f :: (Either a CtrTypePattern, Name) -> m Exp
f (Either a CtrTypePattern
pat, Name
name) = forall {m :: * -> *} {a}.
Quote m =>
Either a CtrTypePattern -> m Exp
bodyFor Either a CtrTypePattern
pat forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name
        bodyFor :: Either a CtrTypePattern -> m Exp
bodyFor (Right CtrTypePattern
x) = forall {m :: * -> *}. Quote m => CtrTypePattern -> m Exp
bodyForPat CtrTypePattern
x
        bodyFor Left{} = [|pure|]
        bodyForPat :: CtrTypePattern -> m Exp
bodyForPat Node{} = [|runContainedH|]
        bodyForPat FlatEmbed{} = [|hsequence|]
        bodyForPat GenEmbed{} = [|hsequence|]
        bodyForPat (InContainer Type
_ CtrTypePattern
pat) = [|traverse $(bodyForPat pat)|]