{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.CodeGen.TH
( _',
apply,
applyVars,
toCon,
ToVar (..),
ToName (..),
ToString (..),
v',
PrintExp (..),
PrintType (..),
PrintDec (..),
m',
m_,
printTypeSynonym,
)
where
import Data.Morpheus.CodeGen.Internal.AST
( AssociatedType (..),
CodeGenConstructor (..),
CodeGenField (..),
CodeGenType (..),
CodeGenTypeName (..),
DerivingClass (..),
FIELD_TYPE_WRAPPER (..),
MethodArgument (..),
TypeClassInstance (..),
TypeValue (..),
getFullName,
)
import Data.Morpheus.CodeGen.Utils
( toHaskellName,
toHaskellTypeName,
)
import Data.Morpheus.Types.Internal.AST
( FieldName,
TypeName,
TypeRef (..),
TypeWrapper (..),
unpackName,
)
import qualified Data.Morpheus.Types.Internal.AST as AST
import qualified Data.Text as T
import Language.Haskell.TH
import Relude hiding
( ToString (..),
Type,
)
_' :: PatQ
_' :: PatQ
_' = forall a b. ToVar a b => a -> b
toVar (String -> Name
mkName String
"_")
v' :: ToVar Name a => a
v' :: forall a. ToVar Name a => a
v' = forall a b. ToVar a b => a -> b
toVar (String -> Name
mkName String
"v")
wrappedType :: TypeWrapper -> Type -> Type
wrappedType :: TypeWrapper -> Type -> Type
wrappedType (TypeList TypeWrapper
xs Bool
nonNull) = Bool -> Type -> Type
withNonNull Bool
nonNull forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
withList forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeWrapper -> Type -> Type
wrappedType TypeWrapper
xs
wrappedType (BaseType Bool
nonNull) = Bool -> Type -> Type
withNonNull Bool
nonNull
{-# INLINE wrappedType #-}
declareTypeRef :: (TypeName -> Type) -> TypeRef -> Type
declareTypeRef :: (TypeName -> Type) -> TypeRef -> Type
declareTypeRef TypeName -> Type
f TypeRef {TypeName
typeConName :: TypeRef -> TypeName
typeConName :: TypeName
typeConName, TypeWrapper
typeWrappers :: TypeRef -> TypeWrapper
typeWrappers :: TypeWrapper
typeWrappers} =
TypeWrapper -> Type -> Type
wrappedType TypeWrapper
typeWrappers (TypeName -> Type
f TypeName
typeConName)
{-# INLINE declareTypeRef #-}
withList :: Type -> Type
withList :: Type -> Type
withList = Type -> Type -> Type
AppT (Name -> Type
ConT ''[])
withNonNull :: Bool -> Type -> Type
withNonNull :: Bool -> Type -> Type
withNonNull Bool
True = forall a. a -> a
id
withNonNull Bool
False = Type -> Type -> Type
AppT (Name -> Type
ConT ''Maybe)
{-# INLINE withNonNull #-}
class ToName a where
toName :: a -> Name
instance ToName String where
toName :: String -> Name
toName = String -> Name
mkName
instance ToName Name where
toName :: Name -> Name
toName = forall a. a -> a
id
instance ToName Text where
toName :: Text -> Name
toName = forall a. ToName a => a -> Name
toName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
instance ToName TypeName where
toName :: TypeName -> Name
toName = forall a. ToName a => a -> Name
toName forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Text
toHaskellTypeName
instance ToName FieldName where
toName :: FieldName -> Name
toName = String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> String
toHaskellName
class ToString a b where
toString :: a -> b
instance ToString a b => ToString a (Q b) where
toString :: a -> Q b
toString = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToString a b => a -> b
toString
instance ToString TypeName Lit where
toString :: TypeName -> Lit
toString = String -> Lit
stringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (t :: NAME). NamePacking a => Name t -> a
unpackName
instance ToString TypeName Pat where
toString :: TypeName -> Pat
toString = Lit -> Pat
LitP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToString a b => a -> b
toString
instance ToString FieldName Lit where
toString :: FieldName -> Lit
toString = String -> Lit
stringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (t :: NAME). NamePacking a => Name t -> a
unpackName
instance ToString TypeName Exp where
toString :: TypeName -> Exp
toString = Lit -> Exp
LitE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToString a b => a -> b
toString
instance ToString FieldName Exp where
toString :: FieldName -> Exp
toString = Lit -> Exp
LitE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToString a b => a -> b
toString
class ToCon a b where
toCon :: a -> b
instance ToCon a b => ToCon a (Q b) where
toCon :: a -> Q b
toCon = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToCon a b => a -> b
toCon
instance (ToName a) => ToCon a Type where
toCon :: a -> Type
toCon = Name -> Type
ConT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToName a => a -> Name
toName
instance (ToName a) => ToCon a Exp where
toCon :: a -> Exp
toCon = Name -> Exp
ConE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToName a => a -> Name
toName
instance (ToName a) => ToCon a Pat where
#if MIN_VERSION_template_haskell(2,18,0)
toCon :: a -> Pat
toCon a
name = Name -> [Type] -> [Pat] -> Pat
ConP (forall a. ToName a => a -> Name
toName a
name) [] []
#else
toCon name = ConP (toName name) []
#endif
class ToVar a b where
toVar :: a -> b
instance ToVar a b => ToVar a (Q b) where
toVar :: a -> Q b
toVar = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToVar a b => a -> b
toVar
instance (ToName a) => ToVar a Type where
toVar :: a -> Type
toVar = Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToName a => a -> Name
toName
instance (ToName a) => ToVar a Exp where
toVar :: a -> Exp
toVar = Name -> Exp
VarE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToName a => a -> Name
toName
instance (ToName a) => ToVar a Pat where
toVar :: a -> Pat
toVar = Name -> Pat
VarP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToName a => a -> Name
toName
class Apply a where
apply :: ToCon i a => i -> [a] -> a
instance Apply TypeQ where
apply :: forall i. ToCon i TypeQ => i -> [TypeQ] -> TypeQ
apply = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToCon a b => a -> b
toCon
instance Apply Type where
apply :: forall i. ToCon i Type => i -> [Type] -> Type
apply = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToCon a b => a -> b
toCon
instance Apply Exp where
apply :: forall i. ToCon i Exp => i -> [Exp] -> Exp
apply = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToCon a b => a -> b
toCon
instance Apply ExpQ where
apply :: forall i. ToCon i ExpQ => i -> [ExpQ] -> ExpQ
apply = 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 b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToCon a b => a -> b
toCon
applyVars ::
( ToName con,
ToName var,
Apply res,
ToCon con res,
ToVar var res
) =>
con ->
[var] ->
res
applyVars :: forall con var res.
(ToName con, ToName var, Apply res, ToCon con res,
ToVar var res) =>
con -> [var] -> res
applyVars con
name [var]
li = forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply con
name (forall a b. (a -> b) -> [a] -> [b]
map forall a b. ToVar a b => a -> b
toVar [var]
li)
#if MIN_VERSION_template_haskell(2,15,0)
typeInstanceDec :: Name -> Type -> Type -> Dec
typeInstanceDec :: Name -> Type -> Type -> Dec
typeInstanceDec Name
typeFamily Type
arg Type
res = TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TySynEqn forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT Name
typeFamily) Type
arg) Type
res)
#else
typeInstanceDec :: Name -> Type -> Type -> Dec
typeInstanceDec typeFamily arg res = TySynInstD typeFamily (TySynEqn [arg] res)
#endif
#if MIN_VERSION_template_haskell(2,17,0)
toTypeVars :: [Name] -> [TyVarBndr ()]
toTypeVars :: [Name] -> [TyVarBndr ()]
toTypeVars = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall flag. Name -> flag -> TyVarBndr flag
PlainTV ())
#else
toTypeVars :: [Name] -> [TyVarBndr]
toTypeVars = map PlainTV
#endif
class PrintExp a where
printExp :: a -> ExpQ
class PrintType a where
printType :: a -> TypeQ
class PrintDec a where
printDec :: a -> Q Dec
printFieldExp :: (FieldName, TypeValue) -> Q FieldExp
printFieldExp :: (FieldName, TypeValue) -> Q FieldExp
printFieldExp (FieldName
fName, TypeValue
fValue) = do
Exp
v <- forall a. PrintExp a => a -> ExpQ
printExp TypeValue
fValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. ToName a => a -> Name
toName FieldName
fName, Exp
v)
instance PrintExp TypeValue where
printExp :: TypeValue -> ExpQ
printExp (TypeValueObject TypeName
name [(FieldName, TypeValue)]
xs) = forall (m :: * -> *). Quote m => Name -> [m FieldExp] -> m Exp
recConE (forall a. ToName a => a -> Name
toName TypeName
name) (forall a b. (a -> b) -> [a] -> [b]
map (FieldName, TypeValue) -> Q FieldExp
printFieldExp [(FieldName, TypeValue)]
xs)
printExp (TypeValueNumber Double
x) = [|x|]
printExp (TypeValueString Text
x) = forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL (Text -> String
T.unpack Text
x))
printExp (TypeValueBool Bool
_) = [|x|]
printExp (TypedValueMaybe (Just TypeValue
x)) = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Just) (forall a. PrintExp a => a -> ExpQ
printExp TypeValue
x)
printExp (TypedValueMaybe Maybe TypeValue
Nothing) = forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Nothing
printExp (TypeValueList [TypeValue]
xs) = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. PrintExp a => a -> ExpQ
printExp [TypeValue]
xs
genName :: DerivingClass -> Name
genName :: DerivingClass -> Name
genName DerivingClass
GENERIC = ''Generic
genName DerivingClass
SHOW = ''Show
genName DerivingClass
CLASS_EQ = ''Eq
printDerivClause :: [DerivingClass] -> DerivClause
printDerivClause :: [DerivingClass] -> DerivClause
printDerivClause [DerivingClass]
derives = Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause forall a. Maybe a
Nothing (forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
ConT forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivingClass -> Name
genName) [DerivingClass]
derives)
applyWrapper :: FIELD_TYPE_WRAPPER -> Type -> Type
applyWrapper :: FIELD_TYPE_WRAPPER -> Type -> Type
applyWrapper FIELD_TYPE_WRAPPER
PARAMETRIZED = (Type -> Type -> Type
`AppT` Type
m')
applyWrapper FIELD_TYPE_WRAPPER
MONAD = Type -> Type -> Type
AppT Type
m'
applyWrapper (SUBSCRIPTION Name
name) = Type -> Type -> Type
AppT (Name -> Type
ConT Name
name)
applyWrapper (ARG TypeName
typeName) = Type -> Name -> Type -> Type
InfixT (Name -> Type
ConT (forall a. ToName a => a -> Name
toName TypeName
typeName)) ''Function
applyWrapper (GQL_WRAPPER TypeWrapper
wrappers) = TypeWrapper -> Type -> Type
wrappedType TypeWrapper
wrappers
applyWrapper (TAGGED_ARG Name
argName FieldName
fieldName TypeRef
typeRef) = Type -> Name -> Type -> Type
InfixT Type
arg ''Function
where
arg :: Type
arg =
Type -> Type -> Type
AppT
( Type -> Type -> Type
AppT
(Name -> Type
ConT Name
argName)
(TyLit -> Type
LitT forall a b. (a -> b) -> a -> b
$ String -> TyLit
StrTyLit forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall a (t :: NAME). NamePacking a => Name t -> a
unpackName FieldName
fieldName)
)
((TypeName -> Type) -> TypeRef -> Type
declareTypeRef forall a b. ToCon a b => a -> b
toCon TypeRef
typeRef)
type Function = (->)
m_ :: Name
m_ :: Name
m_ = String -> Name
mkName String
"m"
m' :: Type
m' :: Type
m' = Name -> Type
VarT Name
m_
constraint :: (Name, Name) -> Q Type
constraint :: (Name, Name) -> TypeQ
constraint (Name
con, Name
name) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply Name
con [forall a b. ToVar a b => a -> b
toVar Name
name]
printConstraints :: [(Name, Name)] -> Q Cxt
printConstraints :: [(Name, Name)] -> Q [Type]
printConstraints = forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Name, Name) -> TypeQ
constraint
printConstructor :: CodeGenConstructor -> Con
printConstructor :: CodeGenConstructor -> Con
printConstructor CodeGenConstructor {constructorFields :: CodeGenConstructor -> [CodeGenField]
constructorFields = [CodeGenField
field], CodeGenTypeName
constructorName :: CodeGenConstructor -> CodeGenTypeName
constructorName :: CodeGenTypeName
..}
| CodeGenField -> FieldName
fieldName CodeGenField
field forall a. Eq a => a -> a -> Bool
== FieldName
"_" = Name -> [BangType] -> Con
NormalC (forall a. ToName a => a -> Name
toName CodeGenTypeName
constructorName) [forall {a} {a} {b}. (a, a, b) -> (a, b)
ignoreName forall a b. (a -> b) -> a -> b
$ CodeGenField -> (Name, Bang, Type)
printField CodeGenField
field]
where
ignoreName :: (a, a, b) -> (a, b)
ignoreName (a
_, a
b, b
t) = (a
b, b
t)
printConstructor CodeGenConstructor {[CodeGenField]
CodeGenTypeName
constructorFields :: [CodeGenField]
constructorName :: CodeGenTypeName
constructorName :: CodeGenConstructor -> CodeGenTypeName
constructorFields :: CodeGenConstructor -> [CodeGenField]
..}
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CodeGenField]
constructorFields = Name -> [BangType] -> Con
NormalC (forall a. ToName a => a -> Name
toName CodeGenTypeName
constructorName) []
| Bool
otherwise = Name -> [(Name, Bang, Type)] -> Con
RecC (forall a. ToName a => a -> Name
toName CodeGenTypeName
constructorName) (forall a b. (a -> b) -> [a] -> [b]
map CodeGenField -> (Name, Bang, Type)
printField [CodeGenField]
constructorFields)
printField :: CodeGenField -> (Name, Bang, Type)
printField :: CodeGenField -> (Name, Bang, Type)
printField CodeGenField {Bool
[FIELD_TYPE_WRAPPER]
FieldName
TypeName
fieldIsNullable :: CodeGenField -> Bool
wrappers :: CodeGenField -> [FIELD_TYPE_WRAPPER]
fieldType :: CodeGenField -> TypeName
fieldIsNullable :: Bool
wrappers :: [FIELD_TYPE_WRAPPER]
fieldType :: TypeName
fieldName :: FieldName
fieldName :: CodeGenField -> FieldName
..} =
( forall a. ToName a => a -> Name
toName FieldName
fieldName,
SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness,
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FIELD_TYPE_WRAPPER -> Type -> Type
applyWrapper (forall a b. ToCon a b => a -> b
toCon TypeName
fieldType) [FIELD_TYPE_WRAPPER]
wrappers
)
printTypeSynonym :: ToName a => a -> [Name] -> Type -> Dec
printTypeSynonym :: forall a. ToName a => a -> [Name] -> Type -> Dec
printTypeSynonym a
name [Name]
params = Name -> [TyVarBndr ()] -> Type -> Dec
TySynD (forall a. ToName a => a -> Name
toName a
name) ([Name] -> [TyVarBndr ()]
toTypeVars [Name]
params)
instance ToName CodeGenTypeName where
toName :: CodeGenTypeName -> Name
toName = forall a. ToName a => a -> Name
toName forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenTypeName -> TypeName
getFullName
instance PrintType CodeGenTypeName where
printType :: CodeGenTypeName -> TypeQ
printType CodeGenTypeName
name = forall con var res.
(ToName con, ToName var, Apply res, ToCon con res,
ToVar var res) =>
con -> [var] -> res
applyVars (forall a. ToName a => a -> Name
toName CodeGenTypeName
name) (forall a b. (a -> b) -> [a] -> [b]
map forall a. ToName a => a -> Name
toName forall a b. (a -> b) -> a -> b
$ CodeGenTypeName -> [Text]
typeParameters CodeGenTypeName
name)
instance ToName AST.DirectiveLocation where
toName :: DirectiveLocation -> Name
toName DirectiveLocation
AST.QUERY = 'AST.QUERY
toName DirectiveLocation
AST.MUTATION = 'AST.MUTATION
toName DirectiveLocation
AST.SUBSCRIPTION = 'AST.SUBSCRIPTION
toName DirectiveLocation
AST.FIELD = 'AST.FIELD
toName DirectiveLocation
AST.FRAGMENT_DEFINITION = 'AST.FRAGMENT_DEFINITION
toName DirectiveLocation
AST.FRAGMENT_SPREAD = 'AST.FRAGMENT_SPREAD
toName DirectiveLocation
AST.INLINE_FRAGMENT = 'AST.INLINE_FRAGMENT
toName DirectiveLocation
AST.SCHEMA = 'AST.SCHEMA
toName DirectiveLocation
AST.SCALAR = 'AST.SCALAR
toName DirectiveLocation
AST.OBJECT = 'AST.OBJECT
toName DirectiveLocation
AST.FIELD_DEFINITION = 'AST.FIELD_DEFINITION
toName DirectiveLocation
AST.ARGUMENT_DEFINITION = 'AST.ARGUMENT_DEFINITION
toName DirectiveLocation
AST.INTERFACE = 'AST.INTERFACE
toName DirectiveLocation
AST.UNION = 'AST.UNION
toName DirectiveLocation
AST.ENUM = 'AST.ENUM
toName DirectiveLocation
AST.ENUM_VALUE = 'AST.ENUM_VALUE
toName DirectiveLocation
AST.INPUT_OBJECT = 'AST.INPUT_OBJECT
toName DirectiveLocation
AST.INPUT_FIELD_DEFINITION = 'AST.INPUT_FIELD_DEFINITION
instance PrintType AssociatedType where
printType :: AssociatedType -> TypeQ
printType (AssociatedLocations [DirectiveLocation]
xs) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
PromotedConsT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
PromotedT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToName a => a -> Name
toName) Type
PromotedNilT [DirectiveLocation]
xs
printType (AssociatedTypeName Name
name) = forall a b. ToCon a b => a -> b
toCon Name
name
instance PrintExp body => PrintDec (TypeClassInstance body) where
printDec :: TypeClassInstance body -> Q Dec
printDec TypeClassInstance {[(Name, Name)]
[(Name, AssociatedType)]
[(Name, MethodArgument, body)]
Name
CodeGenTypeName
typeClassMethods :: forall body.
TypeClassInstance body -> [(Name, MethodArgument, body)]
assoc :: forall body. TypeClassInstance body -> [(Name, AssociatedType)]
typeClassTarget :: forall body. TypeClassInstance body -> CodeGenTypeName
typeClassContext :: forall body. TypeClassInstance body -> [(Name, Name)]
typeClassName :: forall body. TypeClassInstance body -> Name
typeClassMethods :: [(Name, MethodArgument, body)]
assoc :: [(Name, AssociatedType)]
typeClassTarget :: CodeGenTypeName
typeClassContext :: [(Name, Name)]
typeClassName :: Name
..} =
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD
([(Name, Name)] -> Q [Type]
printConstraints [(Name, Name)]
typeClassContext)
TypeQ
headType
(forall a b. (a -> b) -> [a] -> [b]
map (Name, AssociatedType) -> Q Dec
assocTypes [(Name, AssociatedType)]
assoc forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map forall {a}. PrintExp a => (Name, MethodArgument, a) -> Q Dec
printFun [(Name, MethodArgument, body)]
typeClassMethods)
where
printFun :: (Name, MethodArgument, a) -> Q Dec
printFun (Name
funName, MethodArgument
args, a
body) = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
funName [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause (MethodArgument -> [PatQ]
printArg MethodArgument
args) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall a. PrintExp a => a -> ExpQ
printExp a
body)) []]
assocTypes :: (Name, AssociatedType) -> Q Dec
assocTypes (Name
assocName, AssociatedType
type') = do
Type
ty <- forall a. PrintType a => a -> TypeQ
printType CodeGenTypeName
typeClassTarget
Type
assocType <- forall a. PrintType a => a -> TypeQ
printType AssociatedType
type'
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type -> Type -> Dec
typeInstanceDec Name
assocName Type
ty Type
assocType
headType :: TypeQ
headType = do
Type
ty <- forall a. PrintType a => a -> TypeQ
printType CodeGenTypeName
typeClassTarget
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply Name
typeClassName [Type
ty]
printArg :: MethodArgument -> [PatQ]
printArg :: MethodArgument -> [PatQ]
printArg (DestructArgument Name
con [Name]
fields) = [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
con (forall a b. (a -> b) -> [a] -> [b]
map forall a b. ToVar a b => a -> b
toVar [Name]
fields)]
printArg MethodArgument
NoArgument = []
printArg MethodArgument
ProxyArgument = [PatQ
_']
instance PrintDec CodeGenType where
printDec :: CodeGenType -> Q Dec
printDec CodeGenType {[CodeGenConstructor]
[DerivingClass]
CodeGenTypeName
cgDerivations :: CodeGenType -> [DerivingClass]
cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgTypeName :: CodeGenType -> CodeGenTypeName
cgDerivations :: [DerivingClass]
cgConstructors :: [CodeGenConstructor]
cgTypeName :: CodeGenTypeName
..} =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
[Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD
[]
(forall a. ToName a => a -> Name
toName CodeGenTypeName
cgTypeName)
([Name] -> [TyVarBndr ()]
toTypeVars forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. ToName a => a -> Name
toName forall a b. (a -> b) -> a -> b
$ CodeGenTypeName -> [Text]
typeParameters CodeGenTypeName
cgTypeName)
forall a. Maybe a
Nothing
(forall a b. (a -> b) -> [a] -> [b]
map CodeGenConstructor -> Con
printConstructor [CodeGenConstructor]
cgConstructors)
[[DerivingClass] -> DerivClause
printDerivClause [DerivingClass]
cgDerivations]