{-# 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 (..),
    PrintableValue (..),
    TypeClassInstance (..),
    TypeValue (..),
    getFullName,
  )
import Data.Morpheus.CodeGen.Utils
  ( toHaskellName,
    toHaskellTypeName,
  )
import Data.Morpheus.Types.Internal.AST
  ( DirectiveLocation (..),
    FieldName,
    TypeName,
    TypeRef (..),
    TypeWrapper (..),
    unpackName,
  )
import qualified Data.Text as T
import Language.Haskell.TH
import Relude hiding
  ( ToString (..),
    Type,
  )

_' :: PatQ
_' :: PatQ
_' = Name -> 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' = Name -> a
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 (Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
withList (Type -> Type) -> (Type -> Type) -> Type -> Type
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 :: TypeName
typeConName :: TypeRef -> TypeName
typeConName, TypeWrapper
typeWrappers :: TypeWrapper
typeWrappers :: TypeRef -> 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 = Type -> Type
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 = Name -> Name
forall a. a -> a
id

instance ToName Text where
  toName :: Text -> Name
toName = String -> Name
forall a. ToName a => a -> Name
toName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

instance ToName TypeName where
  toName :: TypeName -> Name
toName = Text -> Name
forall a. ToName a => a -> Name
toName (Text -> Name) -> (TypeName -> Text) -> TypeName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Text
toHaskellTypeName

instance ToName FieldName where
  toName :: FieldName -> Name
toName = String -> Name
mkName (String -> Name) -> (FieldName -> String) -> FieldName -> Name
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 = b -> Q b
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Q b) -> (a -> b) -> a -> Q b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
forall a b. ToString a b => a -> b
toString

instance ToString TypeName Lit where
  toString :: TypeName -> Lit
toString = String -> Lit
stringL (String -> Lit) -> (TypeName -> String) -> TypeName -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (TypeName -> Text) -> TypeName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
unpackName

instance ToString TypeName Pat where
  toString :: TypeName -> Pat
toString = Lit -> Pat
LitP (Lit -> Pat) -> (TypeName -> Lit) -> TypeName -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Lit
forall a b. ToString a b => a -> b
toString

instance ToString FieldName Lit where
  toString :: FieldName -> Lit
toString = String -> Lit
stringL (String -> Lit) -> (FieldName -> String) -> FieldName -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (FieldName -> Text) -> FieldName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
unpackName

instance ToString TypeName Exp where
  toString :: TypeName -> Exp
toString = Lit -> Exp
LitE (Lit -> Exp) -> (TypeName -> Lit) -> TypeName -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Lit
forall a b. ToString a b => a -> b
toString

instance ToString FieldName Exp where
  toString :: FieldName -> Exp
toString = Lit -> Exp
LitE (Lit -> Exp) -> (FieldName -> Lit) -> FieldName -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Lit
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 = b -> Q b
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Q b) -> (a -> b) -> a -> Q b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
forall a b. ToCon a b => a -> b
toCon

instance (ToName a) => ToCon a Type where
  toCon :: a -> Type
toCon = Name -> Type
ConT (Name -> Type) -> (a -> Name) -> a -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Name
forall a. ToName a => a -> Name
toName

instance (ToName a) => ToCon a Exp where
  toCon :: a -> Exp
toCon = Name -> Exp
ConE (Name -> Exp) -> (a -> Name) -> a -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Name
forall a. ToName a => a -> Name
toName

{- ORMOLU_DISABLE -}
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 (a -> Name
forall a. ToName a => a -> Name
toName a
name) [] []
#else
  toCon name = ConP (toName name) []
#endif
{- ORMOLU_ENABLE -}

class ToVar a b where
  toVar :: a -> b

instance ToVar a b => ToVar a (Q b) where
  toVar :: a -> Q b
toVar = b -> Q b
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Q b) -> (a -> b) -> a -> Q b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
forall a b. ToVar a b => a -> b
toVar

instance (ToName a) => ToVar a Type where
  toVar :: a -> Type
toVar = Name -> Type
VarT (Name -> Type) -> (a -> Name) -> a -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Name
forall a. ToName a => a -> Name
toName

instance (ToName a) => ToVar a Exp where
  toVar :: a -> Exp
toVar = Name -> Exp
VarE (Name -> Exp) -> (a -> Name) -> a -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Name
forall a. ToName a => a -> Name
toName

instance (ToName a) => ToVar a Pat where
  toVar :: a -> Pat
toVar = Name -> Pat
VarP (Name -> Pat) -> (a -> Name) -> a -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Name
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 = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (TypeQ -> [TypeQ] -> TypeQ)
-> (i -> TypeQ) -> i -> [TypeQ] -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> TypeQ
forall a b. ToCon a b => a -> b
toCon

instance Apply Type where
  apply :: forall i. ToCon i Type => i -> [Type] -> Type
apply = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Type -> [Type] -> Type) -> (i -> Type) -> i -> [Type] -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Type
forall a b. ToCon a b => a -> b
toCon

instance Apply Exp where
  apply :: forall i. ToCon i Exp => i -> [Exp] -> Exp
apply = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Exp -> [Exp] -> Exp) -> (i -> Exp) -> i -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Exp
forall a b. ToCon a b => a -> b
toCon

instance Apply ExpQ where
  apply :: forall i. ToCon i ExpQ => i -> [ExpQ] -> ExpQ
apply = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (ExpQ -> [ExpQ] -> ExpQ) -> (i -> ExpQ) -> i -> [ExpQ] -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> ExpQ
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 = con -> [res] -> res
forall a i. (Apply a, ToCon i a) => i -> [a] -> a
forall i. ToCon i res => i -> [res] -> res
apply con
name ((var -> res) -> [var] -> [res]
forall a b. (a -> b) -> [a] -> [b]
map var -> res
forall a b. ToVar a b => a -> b
toVar [var]
li)

#if MIN_VERSION_template_haskell(2,15,0)
-- fix breaking changes
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 Maybe [TyVarBndr ()]
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

{- ORMOLU_DISABLE -}
#if MIN_VERSION_template_haskell(2,21,0)
toTypeVars :: [Name] -> [TyVarBndr BndrVis]
toTypeVars = map (flip PlainTV BndrReq)
#elif MIN_VERSION_template_haskell(2,17,0)
toTypeVars :: [Name] -> [TyVarBndr ()]
toTypeVars :: [Name] -> [TyVarBndr ()]
toTypeVars = (Name -> TyVarBndr ()) -> [Name] -> [TyVarBndr ()]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> () -> TyVarBndr ()) -> () -> Name -> TyVarBndr ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> () -> TyVarBndr ()
forall flag. Name -> flag -> TyVarBndr flag
PlainTV ())
#else
toTypeVars :: [Name] -> [TyVarBndr]
toTypeVars = map PlainTV
#endif
{- ORMOLU_ENABLE -}
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 <- TypeValue -> ExpQ
forall a. PrintExp a => a -> ExpQ
printExp TypeValue
fValue
  FieldExp -> Q FieldExp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> Name
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) = Name -> [Q FieldExp] -> ExpQ
forall (m :: * -> *). Quote m => Name -> [m FieldExp] -> m Exp
recConE (TypeName -> Name
forall a. ToName a => a -> Name
toName TypeName
name) (((FieldName, TypeValue) -> Q FieldExp)
-> [(FieldName, TypeValue)] -> [Q FieldExp]
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) = Lit -> ExpQ
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)) = ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Just) (TypeValue -> ExpQ
forall a. PrintExp a => a -> ExpQ
printExp TypeValue
x)
  printExp (TypedValueMaybe Maybe TypeValue
Nothing) = Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Nothing
  printExp (TypeValueList [TypeValue]
xs) = [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (TypeValue -> ExpQ) -> [TypeValue] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map TypeValue -> ExpQ
forall a. PrintExp a => a -> ExpQ
printExp [TypeValue]
xs
  printExp (PrintableTypeValue PrintableValue
x) = PrintableValue -> ExpQ
forall a. PrintExp a => a -> ExpQ
printExp PrintableValue
x

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 Maybe DerivStrategy
forall a. Maybe a
Nothing ((DerivingClass -> Type) -> [DerivingClass] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
ConT (Name -> Type) -> (DerivingClass -> Name) -> DerivingClass -> Type
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 (TypeName -> Name
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 (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ String -> TyLit
StrTyLit (String -> TyLit) -> String -> TyLit
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ FieldName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
unpackName FieldName
fieldName)
        )
        ((TypeName -> Type) -> TypeRef -> Type
declareTypeRef TypeName -> Type
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) = Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Type
forall a i. (Apply a, ToCon i a) => i -> [a] -> a
forall i. ToCon i Type => i -> [Type] -> Type
apply Name
con [Name -> Type
forall a b. ToVar a b => a -> b
toVar Name
name]

printConstraints :: [(Name, Name)] -> Q Cxt
printConstraints :: [(Name, Name)] -> Q [Type]
printConstraints = [TypeQ] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt ([TypeQ] -> Q [Type])
-> ([(Name, Name)] -> [TypeQ]) -> [(Name, Name)] -> Q [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, Name) -> TypeQ) -> [(Name, Name)] -> [TypeQ]
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 :: CodeGenTypeName
constructorName :: CodeGenConstructor -> CodeGenTypeName
..}
  | CodeGenField -> FieldName
fieldName CodeGenField
field FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
== FieldName
"_" = Name -> [BangType] -> Con
NormalC (CodeGenTypeName -> Name
forall a. ToName a => a -> Name
toName CodeGenTypeName
constructorName) [(Name, Bang, Type) -> BangType
forall {a} {a} {b}. (a, a, b) -> (a, b)
ignoreName ((Name, Bang, Type) -> BangType) -> (Name, Bang, Type) -> BangType
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 :: CodeGenConstructor -> [CodeGenField]
constructorName :: CodeGenConstructor -> CodeGenTypeName
constructorName :: CodeGenTypeName
constructorFields :: [CodeGenField]
..}
  | [CodeGenField] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CodeGenField]
constructorFields = Name -> [BangType] -> Con
NormalC (CodeGenTypeName -> Name
forall a. ToName a => a -> Name
toName CodeGenTypeName
constructorName) []
  | Bool
otherwise = Name -> [(Name, Bang, Type)] -> Con
RecC (CodeGenTypeName -> Name
forall a. ToName a => a -> Name
toName CodeGenTypeName
constructorName) ((CodeGenField -> (Name, Bang, Type))
-> [CodeGenField] -> [(Name, Bang, Type)]
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]
TypeName
FieldName
fieldName :: CodeGenField -> FieldName
fieldName :: FieldName
fieldType :: TypeName
wrappers :: [FIELD_TYPE_WRAPPER]
fieldIsNullable :: Bool
fieldType :: CodeGenField -> TypeName
wrappers :: CodeGenField -> [FIELD_TYPE_WRAPPER]
fieldIsNullable :: CodeGenField -> Bool
..} =
  ( FieldName -> Name
forall a. ToName a => a -> Name
toName FieldName
fieldName,
    SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness,
    (FIELD_TYPE_WRAPPER -> Type -> Type)
-> Type -> [FIELD_TYPE_WRAPPER] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FIELD_TYPE_WRAPPER -> Type -> Type
applyWrapper (TypeName -> Type
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 (a -> Name
forall a. ToName a => a -> Name
toName a
name) ([Name] -> [TyVarBndr ()]
toTypeVars [Name]
params)

instance ToName CodeGenTypeName where
  toName :: CodeGenTypeName -> Name
toName = TypeName -> Name
forall a. ToName a => a -> Name
toName (TypeName -> Name)
-> (CodeGenTypeName -> TypeName) -> CodeGenTypeName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenTypeName -> TypeName
getFullName

instance PrintType CodeGenTypeName where
  printType :: CodeGenTypeName -> TypeQ
printType CodeGenTypeName
name = Name -> [Name] -> TypeQ
forall con var res.
(ToName con, ToName var, Apply res, ToCon con res,
 ToVar var res) =>
con -> [var] -> res
applyVars (CodeGenTypeName -> Name
forall a. ToName a => a -> Name
toName CodeGenTypeName
name) ((Text -> Name) -> [Text] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Name
forall a. ToName a => a -> Name
toName ([Text] -> [Name]) -> [Text] -> [Name]
forall a b. (a -> b) -> a -> b
$ CodeGenTypeName -> [Text]
typeParameters CodeGenTypeName
name)

instance ToName DirectiveLocation where
  toName :: DirectiveLocation -> Name
toName DirectiveLocation
LOCATION_QUERY = 'LOCATION_QUERY
  toName DirectiveLocation
LOCATION_MUTATION = 'LOCATION_MUTATION
  toName DirectiveLocation
LOCATION_SUBSCRIPTION = 'LOCATION_SUBSCRIPTION
  toName DirectiveLocation
LOCATION_FIELD = 'LOCATION_FIELD
  toName DirectiveLocation
LOCATION_FRAGMENT_DEFINITION = 'LOCATION_FRAGMENT_DEFINITION
  toName DirectiveLocation
LOCATION_FRAGMENT_SPREAD = 'LOCATION_FRAGMENT_SPREAD
  toName DirectiveLocation
LOCATION_INLINE_FRAGMENT = 'LOCATION_INLINE_FRAGMENT
  toName DirectiveLocation
LOCATION_SCHEMA = 'LOCATION_SCHEMA
  toName DirectiveLocation
LOCATION_SCALAR = 'LOCATION_SCALAR
  toName DirectiveLocation
LOCATION_OBJECT = 'LOCATION_OBJECT
  toName DirectiveLocation
LOCATION_FIELD_DEFINITION = 'LOCATION_FIELD_DEFINITION
  toName DirectiveLocation
LOCATION_ARGUMENT_DEFINITION = 'LOCATION_ARGUMENT_DEFINITION
  toName DirectiveLocation
LOCATION_INTERFACE = 'LOCATION_INTERFACE
  toName DirectiveLocation
LOCATION_UNION = 'LOCATION_UNION
  toName DirectiveLocation
LOCATION_ENUM = 'LOCATION_ENUM
  toName DirectiveLocation
LOCATION_ENUM_VALUE = 'LOCATION_ENUM_VALUE
  toName DirectiveLocation
LOCATION_INPUT_OBJECT = 'LOCATION_INPUT_OBJECT
  toName DirectiveLocation
LOCATION_INPUT_FIELD_DEFINITION = 'LOCATION_INPUT_FIELD_DEFINITION

instance PrintType AssociatedType where
  printType :: AssociatedType -> TypeQ
printType (AssociatedLocations [DirectiveLocation]
xs) = Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ (DirectiveLocation -> Type -> Type)
-> Type -> [DirectiveLocation] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT (Type -> Type -> Type)
-> (DirectiveLocation -> Type) -> DirectiveLocation -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
PromotedConsT (Type -> Type)
-> (DirectiveLocation -> Type) -> DirectiveLocation -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
PromotedT (Name -> Type)
-> (DirectiveLocation -> Name) -> DirectiveLocation -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DirectiveLocation -> Name
forall a. ToName a => a -> Name
toName) Type
PromotedNilT [DirectiveLocation]
xs
  printType (AssociatedTypeName Name
name) = Name -> TypeQ
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
typeClassName :: Name
typeClassContext :: [(Name, Name)]
typeClassTarget :: CodeGenTypeName
assoc :: [(Name, AssociatedType)]
typeClassMethods :: [(Name, MethodArgument, body)]
typeClassName :: forall body. TypeClassInstance body -> Name
typeClassContext :: forall body. TypeClassInstance body -> [(Name, Name)]
typeClassTarget :: forall body. TypeClassInstance body -> CodeGenTypeName
assoc :: forall body. TypeClassInstance body -> [(Name, AssociatedType)]
typeClassMethods :: forall body.
TypeClassInstance body -> [(Name, MethodArgument, body)]
..} =
    Q [Type] -> TypeQ -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD
      ([(Name, Name)] -> Q [Type]
printConstraints [(Name, Name)]
typeClassContext)
      TypeQ
headType
      (((Name, AssociatedType) -> Q Dec)
-> [(Name, AssociatedType)] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map (Name, AssociatedType) -> Q Dec
assocTypes [(Name, AssociatedType)]
assoc [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. Semigroup a => a -> a -> a
<> ((Name, MethodArgument, body) -> Q Dec)
-> [(Name, MethodArgument, body)] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map (Name, MethodArgument, body) -> Q Dec
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) = Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
funName [[PatQ] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause (MethodArgument -> [PatQ]
printArg MethodArgument
args) (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (a -> ExpQ
forall a. PrintExp a => a -> ExpQ
printExp a
body)) []]
      assocTypes :: (Name, AssociatedType) -> Q Dec
assocTypes (Name
assocName, AssociatedType
type') = do
        Type
ty <- CodeGenTypeName -> TypeQ
forall a. PrintType a => a -> TypeQ
printType CodeGenTypeName
typeClassTarget
        Type
assocType <- AssociatedType -> TypeQ
forall a. PrintType a => a -> TypeQ
printType AssociatedType
type'
        Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> Type -> Type -> Dec
typeInstanceDec Name
assocName Type
ty Type
assocType
      headType :: TypeQ
headType = do
        Type
ty <- CodeGenTypeName -> TypeQ
forall a. PrintType a => a -> TypeQ
printType CodeGenTypeName
typeClassTarget
        Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Type
forall a i. (Apply a, ToCon i a) => i -> [a] -> a
forall i. ToCon i Type => i -> [Type] -> Type
apply Name
typeClassName [Type
ty]

printArg :: MethodArgument -> [PatQ]
printArg :: MethodArgument -> [PatQ]
printArg (DestructArgument Name
con [Name]
fields) = [Name -> [PatQ] -> PatQ
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
con ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
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
cgTypeName :: CodeGenTypeName
cgConstructors :: [CodeGenConstructor]
cgDerivations :: [DerivingClass]
cgTypeName :: CodeGenType -> CodeGenTypeName
cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgDerivations :: CodeGenType -> [DerivingClass]
..} =
    Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$
      [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD
        []
        (CodeGenTypeName -> Name
forall a. ToName a => a -> Name
toName CodeGenTypeName
cgTypeName)
        ([Name] -> [TyVarBndr ()]
toTypeVars ([Name] -> [TyVarBndr ()]) -> [Name] -> [TyVarBndr ()]
forall a b. (a -> b) -> a -> b
$ (Text -> Name) -> [Text] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Name
forall a. ToName a => a -> Name
toName ([Text] -> [Name]) -> [Text] -> [Name]
forall a b. (a -> b) -> a -> b
$ CodeGenTypeName -> [Text]
typeParameters CodeGenTypeName
cgTypeName)
        Maybe Type
forall a. Maybe a
Nothing
        ((CodeGenConstructor -> Con) -> [CodeGenConstructor] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map CodeGenConstructor -> Con
printConstructor [CodeGenConstructor]
cgConstructors)
        [[DerivingClass] -> DerivClause
printDerivClause [DerivingClass]
cgDerivations]

instance PrintExp PrintableValue where
  printExp :: PrintableValue -> ExpQ
printExp (PrintableValue a
x) = [|x|]