{-# LANGUAGE TemplateHaskell #-}

-- | Generate 'HFoldable' instances via @TemplateHaskell@
module Hyper.TH.Foldable
    ( makeHFoldable
    ) where

import qualified Control.Lens as Lens
import Hyper.Class.Foldable (HFoldable (..))
import Hyper.TH.Internal.Utils
import Language.Haskell.TH
import Language.Haskell.TH.Datatype (ConstructorVariant)

import Hyper.Internal.Prelude

-- | Generate a 'HFoldable' instance
makeHFoldable :: Name -> DecsQ
makeHFoldable :: Name -> DecsQ
makeHFoldable Name
typeName = Name -> Q TypeInfo
makeTypeInfo Name
typeName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeInfo -> DecsQ
makeHFoldableForType

makeHFoldableForType :: TypeInfo -> DecsQ
makeHFoldableForType :: TypeInfo -> DecsQ
makeHFoldableForType 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|HFoldable $(pure (tiInstance info))|]
        [ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'hfoldMap 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 'hfoldMap (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
makeCtr)
        ]
        forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall a. a -> [a] -> [a]
: [])
    where
        ([Type -> Q Con]
_, NodeWitnesses
wit) = TypeInfo -> ([Type -> Q Con], NodeWitnesses)
makeNodeOf TypeInfo
info
        makeCtr :: (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Q Clause
makeCtr (Name, ConstructorVariant, [Either Type CtrTypePattern])
ctr =
            forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
varF, Q Pat
pat] Q Body
body []
            where
                (Q Pat
pat, Q Body
body) = Int
-> NodeWitnesses
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> (Q Pat, Q Body)
makeHFoldMapCtr Int
0 NodeWitnesses
wit (Name, ConstructorVariant, [Either Type CtrTypePattern])
ctr

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|Foldable $(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|HFoldable $(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 []

varF :: Name
varF :: Name
varF = String -> Name
mkName String
"_f"

makeHFoldMapCtr :: Int -> NodeWitnesses -> (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> (Q Pat, Q Body)
makeHFoldMapCtr :: Int
-> NodeWitnesses
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> (Q Pat, Q Body)
makeHFoldMapCtr Int
i NodeWitnesses
wit (Name
cName, ConstructorVariant
_, [Either Type CtrTypePattern]
cFields) =
    (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cName ([Name]
cVars forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (m :: * -> *). Quote m => Name -> m Pat
varP), Q Body
body)
    where
        cVars :: [Name]
cVars =
            [Int
i ..]
                forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"_x" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
                forall a b. a -> (a -> b) -> b
& forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Type CtrTypePattern]
cFields)
        bodyParts :: [Q Exp]
bodyParts =
            forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                (\[Q Exp]
x Q Exp
y -> [Q Exp]
x forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
y))
                ([Either Type CtrTypePattern]
cFields forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Either Type CtrTypePattern -> [Q Exp]
bodyFor)
                ([Name]
cVars forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (m :: * -> *). Quote m => Name -> m Exp
varE)
                forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        body :: Q Body
body =
            case [Q Exp]
bodyParts of
                [] -> [|mempty|]
                [Q Exp]
_ -> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
append [Q Exp]
bodyParts
                forall a b. a -> (a -> b) -> b
& forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
        append :: m Exp -> m Exp -> m Exp
append m Exp
x m Exp
y = [|$x <> $y|]
        f :: Q Exp
f = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
varF
        bodyFor :: Either Type CtrTypePattern -> [Q Exp]
bodyFor (Right CtrTypePattern
x) = CtrTypePattern -> [Q Exp]
bodyForPat CtrTypePattern
x
        bodyFor Left{} = []
        bodyForPat :: CtrTypePattern -> [Q Exp]
bodyForPat (Node Type
t) = [[|$f $(nodeWit wit t)|]]
        bodyForPat (GenEmbed Type
t) = [[|hfoldMap ($f . $(embedWit wit t))|]]
        bodyForPat (InContainer Type
_ CtrTypePattern
pat) = CtrTypePattern -> [Q Exp]
bodyForPat CtrTypePattern
pat forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|foldMap|]
        bodyForPat (FlatEmbed TypeInfo
x) =
            [ forall (m :: * -> *). Quote m => [m Match] -> m Exp
lamCaseE
                ( TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
x
                    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> NodeWitnesses
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> (Q Pat, Q Body)
makeHFoldMapCtr (Int
i forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
cVars) NodeWitnesses
wit
                        forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? []
                )
            ]