{-# LANGUAGE 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
makeHasHPlain :: [Name] -> DecsQ
makeHasHPlain :: [Name] -> DecsQ
makeHasHPlain [Name]
x = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Name -> DecsQ
makeOne [Name]
x forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> 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 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 <- 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall s a. s -> Getting a s a -> a
^. forall s t a b. Field4 s t a b => Lens s t a b
Lens._4) forall a b. a -> (a -> b) -> b
& forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
anHPlainOfCons)
let plains :: [Type]
plains =
[Type]
typs
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ConT Name
hplain `AppT` Type
x | Name
hplain forall a. Eq a => a -> a -> Bool
== ''HPlain -> [Type
x]
Type
_ -> []
[Type]
plainsCtx <- [Type]
plains forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Type -> Type -> Type
AppT (Name -> Type
ConT ''HasHPlain) forall a b. a -> (a -> b) -> b
& [Type] -> Q [Type]
simplifyContext
[Type]
showCtx <- [Type]
typs forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Type -> Type -> Type
AppT (Name -> Type
ConT ''Show) forall a b. a -> (a -> b) -> b
& [Type] -> Q [Type]
simplifyContext
let makeDeriv :: Name -> Q Dec
makeDeriv Name
cls =
forall (m :: * -> *). Quote m => m [Type] -> m Type -> m Dec
standaloneDerivD
([Type]
typs forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Type -> Type -> Type
AppT (Name -> Type
ConT Name
cls) forall a b. a -> (a -> b) -> b
& [Type] -> Q [Type]
simplifyContext)
[t|$(conT cls) (HPlain $(pure (tiInstance info)))|]
(:)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD
(forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type]
showCtx forall a. Semigroup a => a -> a -> a
<> [Type]
plainsCtx))
[t|HasHPlain $(pure (tiInstance info))|]
[ forall (m :: * -> *).
Quote m =>
m [Type]
-> Name
-> [m Type]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
dataInstD (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) ''HPlain [forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo -> Type
tiInstance TypeInfo
info)] forall a. Maybe a
Nothing ([(Con, ClauseQ, ClauseQ, [Type])]
ctrs forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall s t a b. Field1 s t a b => Lens s t a b
Lens._1)) []
, forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
'hPlain
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
[]
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|Lens.iso $(varE fromPlain) $(varE toPlain) . Lens.from _Pure|])
[ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
toPlain ([(Con, ClauseQ, ClauseQ, [Type])]
ctrs forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall s a. s -> Getting a s a -> a
^. forall s t a b. Field2 s t a b => Lens s t a b
Lens._2))
, forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
fromPlain ([(Con, ClauseQ, ClauseQ, [Type])]
ctrs forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall s a. s -> Getting a s a -> a
^. forall s t a b. Field3 s t a b => Lens s t a b
Lens._3))
]
]
]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Name -> Q Dec
makeDeriv [''Eq, ''Ord, ''Show]
where
anHPlainOfCons :: Type -> Bool
anHPlainOfCons (ConT Name
hplain `AppT` Type
x)
| Name
hplain 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 = [Char] -> Name
mkName [Char]
"toPlain"
fromPlain :: Name
fromPlain = [Char] -> Name
mkName [Char]
"fromPlain"
data FieldInfo = FieldInfo
{ FieldInfo -> Type
fieldPlainType :: Type
, FieldInfo -> Q Exp -> Q Exp
fieldToPlain :: Q Exp -> Q Exp
, FieldInfo -> Q Exp -> Q Exp
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) =
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
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \[Field]
xs ->
let plainTypes :: [Type]
plainTypes = [Field]
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Field -> [Type]
plainFieldTypes
cVars :: [Name]
cVars = [Int
0 :: Int ..] forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [Char] -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'x' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show forall a b. a -> (a -> b) -> b
& forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
plainTypes)
in ( [Type]
plainTypes
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness,)
forall a b. a -> (a -> b) -> b
& Name -> [(Bang, Type)] -> Con
NormalC Name
pcon
, forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=) ([Name]
cVars forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (m :: * -> *). Quote m => Name -> m Exp
varE) ([Field]
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Field -> [Exp -> Q Exp]
toPlainFields)
forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
pcon)
forall a b. a -> (a -> b) -> b
& forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
forall a b. a -> (a -> b) -> b
& (forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cName (forall {m :: * -> *}.
Quote m =>
[Name] -> [Field] -> ([m Pat], [Name])
toPlainPat [Name]
cVars [Field]
xs forall s a. s -> Getting a s a -> a
^. forall s t a b. Field1 s t a b => Lens s t a b
Lens._1)] forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? [])
, [Name] -> [Field] -> ([Q Exp], [Name])
fromPlainFields [Name]
cVars [Field]
xs forall s a. s -> Getting a s a -> a
^. forall s t a b. Field1 s t a b => Lens s t a b
Lens._1
forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (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
forall a b. a -> (a -> b) -> b
& (forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
pcon ([Name]
cVars forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (m :: * -> *). Quote m => Name -> m Pat
varP)] forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? [])
, [Field]
xs 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Field -> [Type]
plainFieldTypes
toPlainFields :: Field -> [Exp -> Q Exp]
toPlainFields (NodeField FieldInfo
x) = [FieldInfo -> Q Exp -> Q Exp
fieldToPlain FieldInfo
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure]
toPlainFields (FlatFields FlatInfo
x) = FlatInfo -> [Field]
flatFields FlatInfo
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Field -> [Exp -> Q Exp]
toPlainFields
toPlainPat :: [Name] -> [Field] -> ([m Pat], [Name])
toPlainPat [Name]
cs [] = ([], [Name]
cs)
toPlainPat (Name
c : [Name]
cs) (NodeField{} : [Field]
xs) = [Name] -> [Field] -> ([m Pat], [Name])
toPlainPat [Name]
cs [Field]
xs forall a b. a -> (a -> b) -> b
& forall s t a b. Field1 s t a b => Lens s t a b
Lens._1 forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
c forall a. a -> [a] -> [a]
:)
toPlainPat [Name]
cs0 (FlatFields FlatInfo
x : [Field]
xs) =
[Name] -> [Field] -> ([m Pat], [Name])
toPlainPat [Name]
cs1 [Field]
xs forall a b. a -> (a -> b) -> b
& forall s t a b. Field1 s t a b => Lens s t a b
Lens._1 forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (m Pat
res forall a. a -> [a] -> [a]
:)
where
res :: m Pat
res
| FlatInfo -> Bool
flatIsEmbed FlatInfo
x = m Pat
embed
| Bool
otherwise = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Pure [m Pat
embed]
embed :: m Pat
embed = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (FlatInfo -> Name
flatCtr FlatInfo
x) [m Pat]
r
([m Pat]
r, [Name]
cs1) = [Name] -> [Field] -> ([m Pat], [Name])
toPlainPat [Name]
cs0 (FlatInfo -> [Field]
flatFields FlatInfo
x)
toPlainPat [] [Field]
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"out of variables"
fromPlainFields :: [Name] -> [Field] -> ([Q Exp], [Name])
fromPlainFields [Name]
cs [] = ([], [Name]
cs)
fromPlainFields (Name
c : [Name]
cs) (NodeField FieldInfo
x : [Field]
xs) =
[Name] -> [Field] -> ([Q Exp], [Name])
fromPlainFields [Name]
cs [Field]
xs forall a b. a -> (a -> b) -> b
& forall s t a b. Field1 s t a b => Lens s t a b
Lens._1 forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (FieldInfo -> Q Exp -> Q Exp
fieldFromPlain FieldInfo
x (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
c) forall a. a -> [a] -> [a]
:)
fromPlainFields [Name]
cs0 (FlatFields FlatInfo
x : [Field]
xs) =
[Name] -> [Field] -> ([Q Exp], [Name])
fromPlainFields [Name]
cs1 [Field]
xs forall a b. a -> (a -> b) -> b
& forall s t a b. Field1 s t a b => Lens s t a b
Lens._1 forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Q Exp
res forall a. a -> [a] -> [a]
:)
where
res :: Q Exp
res
| FlatInfo -> Bool
flatIsEmbed FlatInfo
x = Q Exp
embed
| Bool
otherwise = [|Pure $embed|]
embed :: Q Exp
embed = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE (FlatInfo -> Name
flatCtr FlatInfo
x)) [Q Exp]
r
([Q Exp]
r, [Name]
cs1) = [Name] -> [Field] -> ([Q Exp], [Name])
fromPlainFields [Name]
cs0 (FlatInfo -> [Field]
flatFields FlatInfo
x)
fromPlainFields [] [Field]
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"out of variables"
pcon :: Name
pcon =
forall a. Show a => a -> [Char]
show Name
cName
forall a b. a -> (a -> b) -> b
& forall a. [a] -> [a]
reverse
forall a b. a -> (a -> b) -> b
& forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'.')
forall a b. a -> (a -> b) -> b
& forall a. [a] -> [a]
reverse
forall a b. a -> (a -> b) -> b
& (forall a. Semigroup a => a -> a -> a
<> [Char]
"P")
forall a b. a -> (a -> b) -> b
& [Char] -> Name
mkName
forField :: Bool -> Either Type CtrTypePattern -> Q Field
forField Bool
_ (Left Type
t) =
Type -> (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> FieldInfo
FieldInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
normalizeType Type
t
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? forall a. a -> a
id
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? forall a. a -> a
id
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 -> (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> FieldInfo
FieldInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|$(pure t) $(patType p)|]
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? (\Q Exp
x -> [|(hPlain #) <$> $x|])
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? (\Q Exp
x -> [|(^. hPlain) <$> $x|])
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> FieldInfo -> Field
NodeField
where
patType :: CtrTypePattern -> m Type
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') = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t' forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` CtrTypePattern -> m Type
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)] -> 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 forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> FlatInfo -> Field
FlatFields forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Name -> [Field] -> FlatInfo
FlatInfo Bool
isTop Name
n
[(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
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
FamilyI{} -> Q Field
gen
Info
_ ->
do
DatatypeInfo
inner <- Name -> Q DatatypeInfo
D.reifyDatatype Name
c
let subst :: Map Name Type
subst =
[Type]
args forall a. Semigroup a => a -> a -> a
<> [Name -> Type
VarT Name
param]
forall a b. a -> (a -> b) -> b
& forall a b. [a] -> [b] -> [(a, b)]
zip (DatatypeInfo -> [TyVarBndrUnit]
D.datatypeVars DatatypeInfo
inner forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall flag. TyVarBndr_ flag -> Name
D.tvName)
forall a b. a -> (a -> b) -> b
& forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
case DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
inner of
[ConstructorInfo
x] ->
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TypeSubstitution a => Map Name Type -> a -> a
D.applySubstitution Map Name Type
subst) (ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
x)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> FlatInfo -> Field
FlatFields forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Name -> [Field] -> FlatInfo
FlatInfo Bool
isTop (ConstructorInfo -> Name
D.constructorName ConstructorInfo
x)
[ConstructorInfo]
_ -> Q Field
gen
(Type, [Type])
_ -> Q Field
gen
where
gen :: Q Field
gen =
Type -> (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> FieldInfo
FieldInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|HPlain $(pure t)|]
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? (\Q Exp
x -> [|hPlain # $x|])
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? (\Q Exp
f -> [|$f ^. hPlain|])
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> FieldInfo -> Field
NodeField
normalizeType :: Type -> Q Type
normalizeType (ConT Name
g `AppT` VarT Name
v)
| Name
g forall a. Eq a => a -> a -> Bool
== ''GetHyperType Bool -> Bool -> Bool
&& Name
v forall a. Eq a => a -> a -> Bool
== Name
param = [t|Pure|]
normalizeType (Type
x `AppT` Type
y) = Type -> Q Type
normalizeType Type
x forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
normalizeType Type
y
normalizeType Type
x = 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Field -> [Type]
fieldContext