{-# LANGUAGE TemplateHaskell #-}

-- | Generate 'HasHPlain' instances via @TemplateHaskell@

module Hyper.TH.HasPlain
    ( makeHasHPlain
    ) where

import qualified Control.Lens as Lens
import qualified Data.Map as Map
import           Hyper.Class.HasPlain
import           Hyper.TH.Internal.Utils
import           Hyper.Type (GetHyperType)
import           Hyper.Type.Pure (Pure(..), _Pure)
import           Language.Haskell.TH
import qualified Language.Haskell.TH.Datatype as D

import           Hyper.Internal.Prelude

-- | Generate a 'HasHPlain' instance
makeHasHPlain :: [Name] -> DecsQ
makeHasHPlain :: [Name] -> DecsQ
makeHasHPlain [Name]
x = (Name -> DecsQ) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Name -> DecsQ
makeOne [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

makeOne :: Name -> Q [Dec]
makeOne :: Name -> DecsQ
makeOne 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
makeHasHPlainForType

makeHasHPlainForType :: TypeInfo -> Q [Dec]
makeHasHPlainForType :: TypeInfo -> DecsQ
makeHasHPlainForType TypeInfo
info =
    do
        [(Con, ClauseQ, ClauseQ, [Type])]
ctrs <- ((Name, ConstructorVariant, [Either Type CtrTypePattern])
 -> Q (Con, ClauseQ, ClauseQ, [Type]))
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
-> Q [(Con, ClauseQ, ClauseQ, [Type])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Name
-> Name
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Q (Con, ClauseQ, ClauseQ, [Type])
makeCtr (TypeInfo -> Name
tiName TypeInfo
info) (TypeInfo -> Name
tiHyperParam TypeInfo
info)) (TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
info)
        let typs :: [Type]
typs = [(Con, ClauseQ, ClauseQ, [Type])]
ctrs [(Con, ClauseQ, ClauseQ, [Type])]
-> ((Con, ClauseQ, ClauseQ, [Type]) -> [Type]) -> [Type]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Con, ClauseQ, ClauseQ, [Type])
-> Getting [Type] (Con, ClauseQ, ClauseQ, [Type]) [Type] -> [Type]
forall s a. s -> Getting a s a -> a
^. Getting [Type] (Con, ClauseQ, ClauseQ, [Type]) [Type]
forall s t a b. Field4 s t a b => Lens s t a b
Lens._4) [Type] -> ([Type] -> [Type]) -> [Type]
forall a b. a -> (a -> b) -> b
& (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
anHPlainOfCons)
        let plains :: [Type]
plains =
                [Type]
typs
                [Type] -> (Type -> [Type]) -> [Type]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                \case
                ConT Name
hplain `AppT` Type
x | Name
hplain Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''HPlain -> [Type
x]
                Type
_ -> []
        [Type]
plainsCtx <- [Type]
plains [Type] -> (Type -> Type) -> [Type]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Type -> Type -> Type
AppT (Name -> Type
ConT ''HasHPlain) [Type] -> ([Type] -> CxtQ) -> CxtQ
forall a b. a -> (a -> b) -> b
& [Type] -> CxtQ
simplifyContext
        [Type]
showCtx <- [Type]
typs [Type] -> (Type -> Type) -> [Type]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Type -> Type -> Type
AppT (Name -> Type
ConT ''Show) [Type] -> ([Type] -> CxtQ) -> CxtQ
forall a b. a -> (a -> b) -> b
& [Type] -> CxtQ
simplifyContext
        let makeDeriv :: Name -> DecQ
makeDeriv Name
cls =
                CxtQ -> TypeQ -> DecQ
standaloneDerivD
                ([Type]
typs [Type] -> (Type -> Type) -> [Type]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Type -> Type -> Type
AppT (Name -> Type
ConT Name
cls) [Type] -> ([Type] -> CxtQ) -> CxtQ
forall a b. a -> (a -> b) -> b
& [Type] -> CxtQ
simplifyContext)
                [t|$(conT cls) (HPlain $(pure (tiInstance info)))|]
        (:) (Dec -> [Dec] -> [Dec]) -> DecQ -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD
                ([Type] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type]
showCtx [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> [Type]
plainsCtx))
                [t|HasHPlain $(pure (tiInstance  info))|]
                [ CxtQ
-> Name
-> [TypeQ]
-> Maybe Type
-> [ConQ]
-> [DerivClauseQ]
-> DecQ
dataInstD ([Type] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) ''HPlain [Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo -> Type
tiInstance TypeInfo
info)] Maybe Type
forall a. Maybe a
Nothing ([(Con, ClauseQ, ClauseQ, [Type])]
ctrs [(Con, ClauseQ, ClauseQ, [Type])]
-> ((Con, ClauseQ, ClauseQ, [Type]) -> ConQ) -> [ConQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Con -> ConQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Con -> ConQ)
-> ((Con, ClauseQ, ClauseQ, [Type]) -> Con)
-> (Con, ClauseQ, ClauseQ, [Type])
-> ConQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Con, ClauseQ, ClauseQ, [Type])
-> Getting Con (Con, ClauseQ, ClauseQ, [Type]) Con -> Con
forall s a. s -> Getting a s a -> a
^. Getting Con (Con, ClauseQ, ClauseQ, [Type]) Con
forall s t a b. Field1 s t a b => Lens s t a b
Lens._1)) []
                , Name -> [ClauseQ] -> DecQ
funD 'hPlain
                    [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause []
                        (ExpQ -> BodyQ
normalB [|Lens.iso $(varE fromPlain) $(varE toPlain) . Lens.from _Pure|])
                        [ Name -> [ClauseQ] -> DecQ
funD Name
toPlain ([(Con, ClauseQ, ClauseQ, [Type])]
ctrs [(Con, ClauseQ, ClauseQ, [Type])]
-> ((Con, ClauseQ, ClauseQ, [Type]) -> ClauseQ) -> [ClauseQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((Con, ClauseQ, ClauseQ, [Type])
-> Getting ClauseQ (Con, ClauseQ, ClauseQ, [Type]) ClauseQ
-> ClauseQ
forall s a. s -> Getting a s a -> a
^. Getting ClauseQ (Con, ClauseQ, ClauseQ, [Type]) ClauseQ
forall s t a b. Field2 s t a b => Lens s t a b
Lens._2))
                        , Name -> [ClauseQ] -> DecQ
funD Name
fromPlain ([(Con, ClauseQ, ClauseQ, [Type])]
ctrs [(Con, ClauseQ, ClauseQ, [Type])]
-> ((Con, ClauseQ, ClauseQ, [Type]) -> ClauseQ) -> [ClauseQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((Con, ClauseQ, ClauseQ, [Type])
-> Getting ClauseQ (Con, ClauseQ, ClauseQ, [Type]) ClauseQ
-> ClauseQ
forall s a. s -> Getting a s a -> a
^. Getting ClauseQ (Con, ClauseQ, ClauseQ, [Type]) ClauseQ
forall s t a b. Field3 s t a b => Lens s t a b
Lens._3))
                        ]
                    ]
                ]
            Q ([Dec] -> [Dec]) -> DecsQ -> DecsQ
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Name -> DecQ) -> [Name] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Name -> DecQ
makeDeriv [''Eq, ''Ord, ''Show]
    where
        anHPlainOfCons :: Type -> Bool
anHPlainOfCons (ConT Name
hplain `AppT` Type
x)
            | Name
hplain Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''HPlain =
                case Type -> (Type, [Type])
unapply Type
x of
                (ConT{}, [Type]
_) -> Bool
True
                (Type, [Type])
_ -> Bool
False
        anHPlainOfCons Type
_ = Bool
False
        toPlain :: Name
toPlain = String -> Name
mkName String
"toPlain"
        fromPlain :: Name
fromPlain = String -> Name
mkName String
"fromPlain"

data FieldInfo = FieldInfo
    { FieldInfo -> Type
fieldPlainType :: Type
    , FieldInfo -> ExpQ -> ExpQ
fieldToPlain :: Q Exp -> Q Exp
    , FieldInfo -> ExpQ -> ExpQ
fieldFromPlain :: Q Exp -> Q Exp
    }

data FlatInfo = FlatInfo
    { FlatInfo -> Bool
flatIsEmbed :: Bool
    , FlatInfo -> Name
flatCtr :: Name
    , FlatInfo -> [Field]
flatFields :: [Field]
    }

data Field
    = NodeField FieldInfo
    | FlatFields FlatInfo

makeCtr ::
    Name ->
    Name ->
    (Name, D.ConstructorVariant, [Either Type CtrTypePattern]) ->
    Q (Con, ClauseQ, ClauseQ, [Type])
makeCtr :: Name
-> Name
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Q (Con, ClauseQ, ClauseQ, [Type])
makeCtr Name
top Name
param (Name
cName, ConstructorVariant
_, [Either Type CtrTypePattern]
cFields) =
    (Either Type CtrTypePattern -> Q Field)
-> [Either Type CtrTypePattern] -> Q [Field]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Bool -> Either Type CtrTypePattern -> Q Field
forField Bool
True) [Either Type CtrTypePattern]
cFields
    Q [Field]
-> ([Field] -> (Con, ClauseQ, ClauseQ, [Type]))
-> Q (Con, ClauseQ, ClauseQ, [Type])
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
    \[Field]
xs ->
    let plainTypes :: [Type]
plainTypes = [Field]
xs [Field] -> (Field -> [Type]) -> [Type]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Field -> [Type]
plainFieldTypes
        cVars :: [Name]
cVars = [Int
0::Int ..] [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
<&> (Char
'x'Char -> String -> String
forall 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 ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
plainTypes)
    in
    ( [Type]
plainTypes
        [Type] -> (Type -> (Bang, Type)) -> [(Bang, Type)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, )
        [(Bang, Type)] -> ([(Bang, Type)] -> Con) -> Con
forall a b. a -> (a -> b) -> b
& Name -> [(Bang, Type)] -> Con
NormalC Name
pcon
    , (ExpQ -> (Exp -> ExpQ) -> ExpQ)
-> [ExpQ] -> [Exp -> ExpQ] -> [ExpQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ExpQ -> (Exp -> ExpQ) -> ExpQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=) ([Name]
cVars [Name] -> (Name -> ExpQ) -> [ExpQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Name -> ExpQ
varE) ([Field]
xs [Field] -> (Field -> [Exp -> ExpQ]) -> [Exp -> ExpQ]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Field -> [Exp -> ExpQ]
toPlainFields)
        [ExpQ] -> ([ExpQ] -> ExpQ) -> ExpQ
forall a b. a -> (a -> b) -> b
& (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
pcon)
        ExpQ -> (ExpQ -> BodyQ) -> BodyQ
forall a b. a -> (a -> b) -> b
& ExpQ -> BodyQ
normalB
        BodyQ -> (Body -> Clause) -> ClauseQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\Body
x -> [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
ConP Name
cName ([Name] -> [Field] -> ([Pat], [Name])
toPlainPat [Name]
cVars [Field]
xs ([Pat], [Name]) -> Getting [Pat] ([Pat], [Name]) [Pat] -> [Pat]
forall s a. s -> Getting a s a -> a
^. Getting [Pat] ([Pat], [Name]) [Pat]
forall s t a b. Field1 s t a b => Lens s t a b
Lens._1)] Body
x [])
    , [Name] -> [Field] -> ([ExpQ], [Name])
fromPlainFields [Name]
cVars [Field]
xs ([ExpQ], [Name])
-> Getting [ExpQ] ([ExpQ], [Name]) [ExpQ] -> [ExpQ]
forall s a. s -> Getting a s a -> a
^. Getting [ExpQ] ([ExpQ], [Name]) [ExpQ]
forall s t a b. Field1 s t a b => Lens s t a b
Lens._1
        [ExpQ] -> ([ExpQ] -> ExpQ) -> ExpQ
forall a b. a -> (a -> b) -> b
& (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
cName)
        ExpQ -> (ExpQ -> BodyQ) -> BodyQ
forall a b. a -> (a -> b) -> b
& ExpQ -> BodyQ
normalB
        BodyQ -> (Body -> Clause) -> ClauseQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Body
x -> [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
ConP Name
pcon ([Name]
cVars [Name] -> (Name -> Pat) -> [Pat]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Name -> Pat
VarP)] Body
x []
    , [Field]
xs [Field] -> (Field -> [Type]) -> [Type]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Field -> [Type]
fieldContext
    )
    where
        plainFieldTypes :: Field -> [Type]
plainFieldTypes (NodeField FieldInfo
x) = [FieldInfo -> Type
fieldPlainType FieldInfo
x]
        plainFieldTypes (FlatFields FlatInfo
x) = FlatInfo -> [Field]
flatFields FlatInfo
x [Field] -> (Field -> [Type]) -> [Type]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Field -> [Type]
plainFieldTypes
        toPlainFields :: Field -> [Exp -> ExpQ]
toPlainFields (NodeField FieldInfo
x) = [FieldInfo -> ExpQ -> ExpQ
fieldToPlain FieldInfo
x (ExpQ -> ExpQ) -> (Exp -> ExpQ) -> Exp -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure]
        toPlainFields (FlatFields FlatInfo
x) = FlatInfo -> [Field]
flatFields FlatInfo
x [Field] -> (Field -> [Exp -> ExpQ]) -> [Exp -> ExpQ]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Field -> [Exp -> ExpQ]
toPlainFields
        toPlainPat :: [Name] -> [Field] -> ([Pat], [Name])
toPlainPat [Name]
cs [] = ([], [Name]
cs)
        toPlainPat (Name
c:[Name]
cs) (NodeField{} : [Field]
xs) = [Name] -> [Field] -> ([Pat], [Name])
toPlainPat [Name]
cs [Field]
xs ([Pat], [Name])
-> (([Pat], [Name]) -> ([Pat], [Name])) -> ([Pat], [Name])
forall a b. a -> (a -> b) -> b
& ([Pat] -> Identity [Pat])
-> ([Pat], [Name]) -> Identity ([Pat], [Name])
forall s t a b. Field1 s t a b => Lens s t a b
Lens._1 (([Pat] -> Identity [Pat])
 -> ([Pat], [Name]) -> Identity ([Pat], [Name]))
-> ([Pat] -> [Pat]) -> ([Pat], [Name]) -> ([Pat], [Name])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Name -> Pat
VarP Name
c Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
:)
        toPlainPat [Name]
cs0 (FlatFields FlatInfo
x : [Field]
xs) =
            [Name] -> [Field] -> ([Pat], [Name])
toPlainPat [Name]
cs1 [Field]
xs ([Pat], [Name])
-> (([Pat], [Name]) -> ([Pat], [Name])) -> ([Pat], [Name])
forall a b. a -> (a -> b) -> b
& ([Pat] -> Identity [Pat])
-> ([Pat], [Name]) -> Identity ([Pat], [Name])
forall s t a b. Field1 s t a b => Lens s t a b
Lens._1 (([Pat] -> Identity [Pat])
 -> ([Pat], [Name]) -> Identity ([Pat], [Name]))
-> ([Pat] -> [Pat]) -> ([Pat], [Name]) -> ([Pat], [Name])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Pat
res Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
:)
            where
                res :: Pat
res | FlatInfo -> Bool
flatIsEmbed FlatInfo
x = Pat
embed
                    | Bool
otherwise = Name -> [Pat] -> Pat
ConP 'Pure [Pat
embed]
                embed :: Pat
embed = Name -> [Pat] -> Pat
ConP (FlatInfo -> Name
flatCtr FlatInfo
x) [Pat]
r
                ([Pat]
r, [Name]
cs1) = [Name] -> [Field] -> ([Pat], [Name])
toPlainPat [Name]
cs0 (FlatInfo -> [Field]
flatFields FlatInfo
x)
        toPlainPat [] [Field]
_ = String -> ([Pat], [Name])
forall a. HasCallStack => String -> a
error String
"out of variables"
        fromPlainFields :: [Name] -> [Field] -> ([ExpQ], [Name])
fromPlainFields [Name]
cs [] = ([], [Name]
cs)
        fromPlainFields (Name
c:[Name]
cs) (NodeField FieldInfo
x : [Field]
xs) =
            [Name] -> [Field] -> ([ExpQ], [Name])
fromPlainFields [Name]
cs [Field]
xs ([ExpQ], [Name])
-> (([ExpQ], [Name]) -> ([ExpQ], [Name])) -> ([ExpQ], [Name])
forall a b. a -> (a -> b) -> b
& ([ExpQ] -> Identity [ExpQ])
-> ([ExpQ], [Name]) -> Identity ([ExpQ], [Name])
forall s t a b. Field1 s t a b => Lens s t a b
Lens._1 (([ExpQ] -> Identity [ExpQ])
 -> ([ExpQ], [Name]) -> Identity ([ExpQ], [Name]))
-> ([ExpQ] -> [ExpQ]) -> ([ExpQ], [Name]) -> ([ExpQ], [Name])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (FieldInfo -> ExpQ -> ExpQ
fieldFromPlain FieldInfo
x (Name -> ExpQ
varE Name
c) ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
:)
        fromPlainFields [Name]
cs0 (FlatFields FlatInfo
x : [Field]
xs) =
            [Name] -> [Field] -> ([ExpQ], [Name])
fromPlainFields [Name]
cs1 [Field]
xs ([ExpQ], [Name])
-> (([ExpQ], [Name]) -> ([ExpQ], [Name])) -> ([ExpQ], [Name])
forall a b. a -> (a -> b) -> b
& ([ExpQ] -> Identity [ExpQ])
-> ([ExpQ], [Name]) -> Identity ([ExpQ], [Name])
forall s t a b. Field1 s t a b => Lens s t a b
Lens._1 (([ExpQ] -> Identity [ExpQ])
 -> ([ExpQ], [Name]) -> Identity ([ExpQ], [Name]))
-> ([ExpQ] -> [ExpQ]) -> ([ExpQ], [Name]) -> ([ExpQ], [Name])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (ExpQ
res ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
:)
            where
                res :: ExpQ
res | FlatInfo -> Bool
flatIsEmbed FlatInfo
x = ExpQ
embed
                    | Bool
otherwise = [|Pure $embed|]
                embed :: ExpQ
embed = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (FlatInfo -> Name
flatCtr FlatInfo
x)) [ExpQ]
r
                ([ExpQ]
r, [Name]
cs1) = [Name] -> [Field] -> ([ExpQ], [Name])
fromPlainFields [Name]
cs0 (FlatInfo -> [Field]
flatFields FlatInfo
x)
        fromPlainFields [] [Field]
_ = String -> ([ExpQ], [Name])
forall a. HasCallStack => String -> a
error String
"out of variables"
        pcon :: Name
pcon =
            Name -> String
forall a. Show a => a -> String
show Name
cName String -> (String -> String) -> String
forall a b. a -> (a -> b) -> b
& String -> String
forall a. [a] -> [a]
reverse String -> (String -> String) -> String
forall a b. a -> (a -> b) -> b
& (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') String -> (String -> String) -> String
forall a b. a -> (a -> b) -> b
& String -> String
forall a. [a] -> [a]
reverse
            String -> (String -> String) -> String
forall a b. a -> (a -> b) -> b
& (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"P") String -> (String -> Name) -> Name
forall a b. a -> (a -> b) -> b
& String -> Name
mkName
        forField :: Bool -> Either Type CtrTypePattern -> Q Field
forField Bool
_ (Left Type
t) =
            Type -> (ExpQ -> ExpQ) -> (ExpQ -> ExpQ) -> FieldInfo
FieldInfo
            (Type -> (ExpQ -> ExpQ) -> (ExpQ -> ExpQ) -> FieldInfo)
-> TypeQ -> Q ((ExpQ -> ExpQ) -> (ExpQ -> ExpQ) -> FieldInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> TypeQ
normalizeType Type
t
            Q ((ExpQ -> ExpQ) -> (ExpQ -> ExpQ) -> FieldInfo)
-> (ExpQ -> ExpQ) -> Q ((ExpQ -> ExpQ) -> FieldInfo)
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? ExpQ -> ExpQ
forall a. a -> a
id Q ((ExpQ -> ExpQ) -> FieldInfo) -> (ExpQ -> ExpQ) -> Q FieldInfo
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? ExpQ -> ExpQ
forall a. a -> a
id Q FieldInfo -> (FieldInfo -> Field) -> Q Field
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> FieldInfo -> Field
NodeField
        forField Bool
isTop (Right CtrTypePattern
x) = Bool -> CtrTypePattern -> Q Field
forPat Bool
isTop CtrTypePattern
x
        forPat :: Bool -> CtrTypePattern -> Q Field
forPat Bool
isTop (Node Type
x) = Bool -> Type -> Q Field
forGen Bool
isTop Type
x
        forPat Bool
isTop (GenEmbed Type
x) = Bool -> Type -> Q Field
forGen Bool
isTop Type
x
        forPat Bool
_ (InContainer Type
t CtrTypePattern
p) =
            Type -> (ExpQ -> ExpQ) -> (ExpQ -> ExpQ) -> FieldInfo
FieldInfo
            (Type -> (ExpQ -> ExpQ) -> (ExpQ -> ExpQ) -> FieldInfo)
-> TypeQ -> Q ((ExpQ -> ExpQ) -> (ExpQ -> ExpQ) -> FieldInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|$(pure t) $(patType p)|]
            Q ((ExpQ -> ExpQ) -> (ExpQ -> ExpQ) -> FieldInfo)
-> (ExpQ -> ExpQ) -> Q ((ExpQ -> ExpQ) -> FieldInfo)
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? (\ExpQ
x -> [|(hPlain #) <$> $x|])
            Q ((ExpQ -> ExpQ) -> FieldInfo) -> (ExpQ -> ExpQ) -> Q FieldInfo
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? (\ExpQ
x -> [|(^. hPlain) <$> $x|])
            Q FieldInfo -> (FieldInfo -> Field) -> Q Field
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> FieldInfo -> Field
NodeField
            where
                patType :: CtrTypePattern -> TypeQ
patType (Node Type
x) = [t|HPlain $(pure x)|]
                patType (GenEmbed Type
x) = [t|HPlain $(pure x)|]
                patType (FlatEmbed TypeInfo
x) = [t|HPlain $(pure (tiInstance x))|]
                patType (InContainer Type
t' CtrTypePattern
p') = Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t' TypeQ -> TypeQ -> TypeQ
`appT` CtrTypePattern -> TypeQ
patType CtrTypePattern
p'
        forPat Bool
isTop (FlatEmbed TypeInfo
x) =
            case TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
x of
            [(Name
n, ConstructorVariant
_, [Either Type CtrTypePattern]
xs)] -> (Either Type CtrTypePattern -> Q Field)
-> [Either Type CtrTypePattern] -> Q [Field]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Bool -> Either Type CtrTypePattern -> Q Field
forField Bool
False) [Either Type CtrTypePattern]
xs Q [Field] -> ([Field] -> FlatInfo) -> Q FlatInfo
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Name -> [Field] -> FlatInfo
FlatInfo Bool
isTop Name
n Q FlatInfo -> (FlatInfo -> Field) -> Q Field
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> FlatInfo -> Field
FlatFields
            [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
_ -> Bool -> Type -> Q Field
forGen Bool
isTop (TypeInfo -> Type
tiInstance TypeInfo
x)
        forGen :: Bool -> Type -> Q Field
forGen Bool
isTop Type
t =
            case Type -> (Type, [Type])
unapply Type
t of
            (ConT Name
c, [Type]
args) ->
                Name -> Q Info
reify Name
c
                Q Info -> (Info -> Q Field) -> Q Field
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                \case
                FamilyI{} -> Q Field
gen -- Not expanding type families currently
                Info
_ ->
                    do
                        DatatypeInfo
inner <- Name -> Q DatatypeInfo
D.reifyDatatype Name
c
                        let subst :: Map Name Type
subst =
                                [Type]
args [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> [Name -> Type
VarT Name
param]
                                [Type] -> ([Type] -> [(Name, Type)]) -> [(Name, Type)]
forall a b. a -> (a -> b) -> b
& [Name] -> [Type] -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip (DatatypeInfo -> [TyVarBndrUnit]
D.datatypeVars DatatypeInfo
inner [TyVarBndrUnit] -> (TyVarBndrUnit -> Name) -> [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> TyVarBndrUnit -> Name
forall flag. TyVarBndrUnit -> Name
D.tvName)
                                [(Name, Type)]
-> ([(Name, Type)] -> Map Name Type) -> Map Name Type
forall a b. a -> (a -> b) -> b
& [(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                        case DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
inner of
                            [ConstructorInfo
x] ->
                                ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
x
                                [Type] -> (Type -> Type) -> [Type]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
D.applySubstitution Map Name Type
subst
                                [Type]
-> ([Type] -> Q [Either Type CtrTypePattern])
-> Q [Either Type CtrTypePattern]
forall a b. a -> (a -> b) -> b
& (Type -> Q (Either Type CtrTypePattern))
-> [Type] -> Q [Either Type CtrTypePattern]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Name -> Name -> Type -> Q (Either Type CtrTypePattern)
matchType Name
top Name
param)
                                Q [Either Type CtrTypePattern]
-> ([Either Type CtrTypePattern] -> Q [Field]) -> Q [Field]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Either Type CtrTypePattern -> Q Field)
-> [Either Type CtrTypePattern] -> Q [Field]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Bool -> Either Type CtrTypePattern -> Q Field
forField Bool
False)
                                Q [Field] -> ([Field] -> FlatInfo) -> Q FlatInfo
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Name -> [Field] -> FlatInfo
FlatInfo Bool
isTop (ConstructorInfo -> Name
D.constructorName ConstructorInfo
x)
                                Q FlatInfo -> (FlatInfo -> Field) -> Q Field
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> FlatInfo -> Field
FlatFields
                            [ConstructorInfo]
_ -> Q Field
gen
            (Type, [Type])
_ -> Q Field
gen
            where
                gen :: Q Field
gen =
                    Type -> (ExpQ -> ExpQ) -> (ExpQ -> ExpQ) -> FieldInfo
FieldInfo
                    (Type -> (ExpQ -> ExpQ) -> (ExpQ -> ExpQ) -> FieldInfo)
-> TypeQ -> Q ((ExpQ -> ExpQ) -> (ExpQ -> ExpQ) -> FieldInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|HPlain $(pure t)|]
                    Q ((ExpQ -> ExpQ) -> (ExpQ -> ExpQ) -> FieldInfo)
-> (ExpQ -> ExpQ) -> Q ((ExpQ -> ExpQ) -> FieldInfo)
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? (\ExpQ
x -> [|hPlain # $x|])
                    Q ((ExpQ -> ExpQ) -> FieldInfo) -> (ExpQ -> ExpQ) -> Q FieldInfo
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? (\ExpQ
f -> [|$f ^. hPlain|])
                    Q FieldInfo -> (FieldInfo -> Field) -> Q Field
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> FieldInfo -> Field
NodeField
        normalizeType :: Type -> TypeQ
normalizeType (ConT Name
g `AppT` VarT Name
v)
            | Name
g Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''GetHyperType Bool -> Bool -> Bool
&& Name
v Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
param = [t|Pure|]
        normalizeType (Type
x `AppT` Type
y) = Type -> TypeQ
normalizeType Type
x TypeQ -> TypeQ -> TypeQ
`appT` Type -> TypeQ
normalizeType Type
y
        normalizeType Type
x = Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
x
        fieldContext :: Field -> [Type]
fieldContext (NodeField FieldInfo
x) = [FieldInfo -> Type
fieldPlainType FieldInfo
x]
        fieldContext (FlatFields FlatInfo
x) = FlatInfo -> [Field]
flatFields FlatInfo
x [Field] -> (Field -> [Type]) -> [Type]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Field -> [Type]
fieldContext