{-# 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 (HTraversable(..), ContainedH(..))
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 =
    [DecsQ] -> Q [[Dec]]
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
    ] 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 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 =
    [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
makeHTraversableAndFoldable 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 'HTraversable' and 'Hyper.Class.Foldable.HFoldable' instances
makeHTraversableAndFoldable :: Name -> DecsQ
makeHTraversableAndFoldable :: Name -> DecsQ
makeHTraversableAndFoldable Name
x =
    [DecsQ] -> Q [[Dec]]
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
    ] 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 a 'HTraversable' instance
makeHTraversable :: Name -> DecsQ
makeHTraversable :: Name -> DecsQ
makeHTraversable 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
makeHTraversableForType

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

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