{-# 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 = 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 -- Not expanding type families currently
                            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