{-# 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 Q TypeInfo -> (TypeInfo -> DecsQ) -> DecsQ
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 =
    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|HFoldable $(pure (tiInstance info))|]
    [ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'hfoldMap 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 'hfoldMap (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
makeCtr)
    ]
    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
        ([Pred -> Q Con]
_, NodeWitnesses
wit) = TypeInfo -> ([Pred -> Q Con], NodeWitnesses)
makeNodeOf TypeInfo
info
        makeCtr :: (Name, ConstructorVariant, [Either Pred CtrTypePattern]) -> ClauseQ
makeCtr (Name, ConstructorVariant, [Either Pred CtrTypePattern])
ctr =
            [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> PatQ
varP Name
varF, PatQ
pat] BodyQ
body []
            where
                (PatQ
pat, BodyQ
body) = Int
-> NodeWitnesses
-> (Name, ConstructorVariant, [Either Pred CtrTypePattern])
-> (PatQ, BodyQ)
makeHFoldMapCtr Int
0 NodeWitnesses
wit (Name, ConstructorVariant, [Either Pred CtrTypePattern])
ctr

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

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 Pred CtrTypePattern])
-> (PatQ, BodyQ)
makeHFoldMapCtr Int
i NodeWitnesses
wit (Name
cName, ConstructorVariant
_, [Either Pred CtrTypePattern]
cFields) =
    (Name -> [PatQ] -> PatQ
conP Name
cName ([Name]
cVars [Name] -> (Name -> PatQ) -> [PatQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Name -> PatQ
varP), BodyQ
body)
    where
        cVars :: [Name]
cVars =
            [Int
i ..] [Int] -> (Int -> String) -> [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Int -> String
forall a. Show a => a -> String
show [String] -> (String -> String) -> [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String
"_x" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) [String] -> (String -> Name) -> [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> String -> Name
mkName
            [Name] -> ([Name] -> [Name]) -> [Name]
forall a b. a -> (a -> b) -> b
& Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take ([Either Pred CtrTypePattern] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Pred CtrTypePattern]
cFields)
        bodyParts :: [ExpQ]
bodyParts =
            ([ExpQ] -> ExpQ -> [ExpQ]) -> [[ExpQ]] -> [ExpQ] -> [[ExpQ]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\[ExpQ]
x ExpQ
y -> [ExpQ]
x [ExpQ] -> (ExpQ -> ExpQ) -> [ExpQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
y))
            ([Either Pred CtrTypePattern]
cFields [Either Pred CtrTypePattern]
-> (Either Pred CtrTypePattern -> [ExpQ]) -> [[ExpQ]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Either Pred CtrTypePattern -> [ExpQ]
bodyFor)
            ([Name]
cVars [Name] -> (Name -> ExpQ) -> [ExpQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Name -> ExpQ
varE)
            [[ExpQ]] -> ([[ExpQ]] -> [ExpQ]) -> [ExpQ]
forall a b. a -> (a -> b) -> b
& [[ExpQ]] -> [ExpQ]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        body :: BodyQ
body =
            case [ExpQ]
bodyParts of
            [] -> [|mempty|]
            [ExpQ]
_ -> (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 ExpQ -> ExpQ -> ExpQ
append [ExpQ]
bodyParts
            ExpQ -> (ExpQ -> BodyQ) -> BodyQ
forall a b. a -> (a -> b) -> b
& ExpQ -> BodyQ
normalB
        append :: ExpQ -> ExpQ -> ExpQ
append ExpQ
x ExpQ
y = [|$x <> $y|]
        f :: ExpQ
f = Name -> ExpQ
varE Name
varF
        bodyFor :: Either Pred CtrTypePattern -> [ExpQ]
bodyFor (Right CtrTypePattern
x) = CtrTypePattern -> [ExpQ]
bodyForPat CtrTypePattern
x
        bodyFor Left{} = []
        bodyForPat :: CtrTypePattern -> [ExpQ]
bodyForPat (Node Pred
t) = [[|$f $(nodeWit wit t)|]]
        bodyForPat (GenEmbed Pred
t) = [[|hfoldMap ($f . $(embedWit wit t))|]]
        bodyForPat (InContainer Pred
_ CtrTypePattern
pat) = CtrTypePattern -> [ExpQ]
bodyForPat CtrTypePattern
pat [ExpQ] -> (ExpQ -> ExpQ) -> [ExpQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ExpQ -> ExpQ -> ExpQ
appE [|foldMap|]
        bodyForPat (FlatEmbed TypeInfo
x) =
            [ [MatchQ] -> ExpQ
lamCaseE
                (TypeInfo
-> [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
tiConstructors TypeInfo
x
                    [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
-> ((Name, ConstructorVariant, [Either Pred CtrTypePattern])
    -> (PatQ, BodyQ))
-> [(PatQ, BodyQ)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Int
-> NodeWitnesses
-> (Name, ConstructorVariant, [Either Pred CtrTypePattern])
-> (PatQ, BodyQ)
makeHFoldMapCtr (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
cVars) NodeWitnesses
wit
                    [(PatQ, BodyQ)] -> ((PatQ, BodyQ) -> MatchQ) -> [MatchQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(PatQ
p, BodyQ
b) -> PatQ -> BodyQ -> [DecQ] -> MatchQ
match PatQ
p BodyQ
b []
                )
            ]