{-# language DataKinds         #-}
{-# language OverloadedStrings #-}
{-# language TemplateHaskell   #-}
{-# language TupleSections     #-}
{-# language ViewPatterns      #-}
{-|
Description : Quasi-quoters for GraphQL schemas

Read @.graphql@ files as a 'Mu.Schema.Definition.Schema'
and 'Package' with one 'Service' per object in the schema.
-}
module Mu.GraphQL.Quasi (
  graphql
, graphql'
) where

import           Control.Monad.IO.Class        (liftIO)
import           Data.Coerce                   (coerce)
import qualified Data.HashMap.Strict           as HM
import           Data.List                     (foldl')
import           Data.Maybe                    (catMaybes)
import qualified Data.Text                     as T
import qualified Data.Text.IO                  as TIO
import           Data.UUID                     (UUID)
import qualified Language.GraphQL.Draft.Syntax as GQL
import           Language.Haskell.TH

import           Mu.GraphQL.Annotations
import           Mu.GraphQL.Quasi.LostParser   (parseTypeSysDefinition)
import           Mu.Rpc
import           Mu.Schema.Definition

-- | Imports an GraphQL schema definition from a file.
graphql :: String   -- ^ Name for the 'Package' type, the 'Schema' is derived from it
        -> FilePath -- ^ Route to the file
        -> Q [Dec]
graphql :: String -> String -> Q [Dec]
graphql String
name = String -> String -> String -> Q [Dec]
graphql' (String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Schema") String
name

-- | Imports an GraphQL schema definition from a file.
graphql' :: String   -- ^ Name for the 'Schema' type
         -> String   -- ^ Name for the 'Package' type
         -> FilePath -- ^ Route to the file
         -> Q [Dec]
graphql' :: String -> String -> String -> Q [Dec]
graphql' String
scName String
svName String
file = do
  Text
schema <- IO Text -> Q Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> Q Text) -> IO Text -> Q Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
TIO.readFile String
file
  case Text -> Either Text [TypeSystemDefinition]
parseTypeSysDefinition Text
schema of
    Left Text
e  -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"could not parse graphql spec: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
e)
    Right [TypeSystemDefinition]
p -> String -> String -> [TypeSystemDefinition] -> Q [Dec]
graphqlToDecls String
scName String
svName [TypeSystemDefinition]
p

type TypeMap   = HM.HashMap T.Text GQLType
type SchemaMap = HM.HashMap T.Text GQL.OperationType

data Result =
    GQLScalar
  | GQLSchema  Type
  | GQLService Type [(T.Text, (T.Text, (T.Text, Type)))]

data GQLType =
    Enum
  | Object
  | Scalar
  | InputObject
  | Other

classifySchema :: [GQL.SchemaDefinition] -> SchemaMap
classifySchema :: [SchemaDefinition] -> SchemaMap
classifySchema = (SchemaMap -> SchemaDefinition -> SchemaMap)
-> SchemaMap -> [SchemaDefinition] -> SchemaMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SchemaMap -> SchemaDefinition -> SchemaMap
schemaToMap SchemaMap
forall k v. HashMap k v
HM.empty
  where
    schemaToMap :: SchemaMap -> GQL.SchemaDefinition -> SchemaMap
    schemaToMap :: SchemaMap -> SchemaDefinition -> SchemaMap
schemaToMap SchemaMap
mp (GQL.SchemaDefinition Maybe [Directive]
_ [RootOperationTypeDefinition]
ops) = (SchemaMap -> RootOperationTypeDefinition -> SchemaMap)
-> SchemaMap -> [RootOperationTypeDefinition] -> SchemaMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SchemaMap -> RootOperationTypeDefinition -> SchemaMap
operationToKeyValue SchemaMap
mp [RootOperationTypeDefinition]
ops
    operationToKeyValue :: SchemaMap -> GQL.RootOperationTypeDefinition -> SchemaMap
    operationToKeyValue :: SchemaMap -> RootOperationTypeDefinition -> SchemaMap
operationToKeyValue SchemaMap
mp (GQL.RootOperationTypeDefinition OperationType
opType (NamedType -> Text
coerce -> Text
name)) = Text -> OperationType -> SchemaMap -> SchemaMap
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
name OperationType
opType SchemaMap
mp

classify :: [GQL.TypeDefinition] -> TypeMap
classify :: [TypeDefinition] -> TypeMap
classify = [(Text, GQLType)] -> TypeMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, GQLType)] -> TypeMap)
-> ([TypeDefinition] -> [(Text, GQLType)])
-> [TypeDefinition]
-> TypeMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeDefinition -> (Text, GQLType)
typeToKeyValue (TypeDefinition -> (Text, GQLType))
-> [TypeDefinition] -> [(Text, GQLType)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
  where
    typeToKeyValue :: GQL.TypeDefinition -> (T.Text, GQLType)
    typeToKeyValue :: TypeDefinition -> (Text, GQLType)
typeToKeyValue (GQL.TypeDefinitionScalar (GQL.ScalarTypeDefinition Maybe Description
_ Name
name [Directive]
_))
      = (Name -> Text
coerce Name
name, GQLType
Scalar)
    typeToKeyValue (GQL.TypeDefinitionObject (GQL.ObjectTypeDefinition Maybe Description
_ Name
name [NamedType]
_ [Directive]
_ [FieldDefinition]
_))
      = (Name -> Text
coerce Name
name, GQLType
Object)
    typeToKeyValue (GQL.TypeDefinitionInterface (GQL.InterfaceTypeDefinition Maybe Description
_ Name
name [Directive]
_ [FieldDefinition]
_))
      = (Name -> Text
coerce Name
name, GQLType
Other)
    typeToKeyValue (GQL.TypeDefinitionUnion (GQL.UnionTypeDefinition Maybe Description
_ Name
name [Directive]
_ [NamedType]
_))
      = (Name -> Text
coerce Name
name, GQLType
Other)
    typeToKeyValue (GQL.TypeDefinitionEnum (GQL.EnumTypeDefinition Maybe Description
_ Name
name [Directive]
_ [EnumValueDefinition]
_))
      = (Name -> Text
coerce Name
name, GQLType
Enum)
    typeToKeyValue (GQL.TypeDefinitionInputObject (GQL.InputObjectTypeDefinition Maybe Description
_ Name
name [Directive]
_ [InputValueDefinition]
_))
      = (Name -> Text
coerce Name
name, GQLType
InputObject)

-- | Constructs the GraphQL tree splitting between Schemas and Services.
graphqlToDecls :: String -> String -> [GQL.TypeSystemDefinition] -> Q [Dec]
graphqlToDecls :: String -> String -> [TypeSystemDefinition] -> Q [Dec]
graphqlToDecls String
schemaName String
serviceName [TypeSystemDefinition]
allTypes = do
  let schemaName' :: Name
schemaName'  = String -> Name
mkName String
schemaName
      serviceName' :: Name
serviceName' = String -> Name
mkName String
serviceName
      types :: [TypeDefinition]
types        = [TypeDefinition
t | GQL.TypeSystemDefinitionType TypeDefinition
t <- [TypeSystemDefinition]
allTypes]
      schTypes :: [SchemaDefinition]
schTypes     = [SchemaDefinition
t | GQL.TypeSystemDefinitionSchema SchemaDefinition
t <- [TypeSystemDefinition]
allTypes]
      typeMap :: TypeMap
typeMap      = [TypeDefinition] -> TypeMap
classify [TypeDefinition]
types
      schMap :: SchemaMap
schMap       = [SchemaDefinition] -> SchemaMap
classifySchema [SchemaDefinition]
schTypes
  [Result]
rs <- (TypeDefinition -> Q Result) -> [TypeDefinition] -> Q [Result]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Name -> TypeMap -> SchemaMap -> TypeDefinition -> Q Result
typeToDec Name
schemaName' TypeMap
typeMap SchemaMap
schMap) [TypeDefinition]
types
  let schemaTypes :: [Type]
schemaTypes  = [Type
x | GQLSchema  Type
x <- [Result]
rs]
      serviceTypes :: [Type]
serviceTypes = [Type
x | GQLService Type
x [(Text, (Text, (Text, Type)))]
_ <- [Result]
rs]
      defaultDefs :: [(Text, (Text, (Text, Type)))]
defaultDefs  = [[(Text, (Text, (Text, Type)))]] -> [(Text, (Text, (Text, Type)))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Text, (Text, (Text, Type)))]
d | GQLService Type
_ [(Text, (Text, (Text, Type)))]
d <- [Result]
rs]
  Dec
schemaDec <- Name -> [TyVarBndr] -> TypeQ -> DecQ
tySynD Name
schemaName' [] (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ [Type] -> Type
typesToList [Type]
schemaTypes)
  Type
pkgTy <- [t| 'Package ('Just $(textToStrLit $ T.pack serviceName))
                        $(pure $ typesToList serviceTypes) |]
  Dec
serviceDec <- Name -> [TyVarBndr] -> TypeQ -> DecQ
tySynD Name
serviceName' [] (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
pkgTy)
  [Dec]
defaultDec <- [d| type instance AnnotatedPackage DefaultValue $(pure pkgTy) =
                      $(typesToList <$> traverse defaultDeclToTy defaultDefs) |]
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
schemaDec Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
serviceDec Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
defaultDec

defaultDeclToTy :: (T.Text, (T.Text, (T.Text, Type))) -> Q Type
defaultDeclToTy :: (Text, (Text, (Text, Type))) -> TypeQ
defaultDeclToTy (Text
sn, (Text
mn, (Text
an, Type
dv)))
  = [t| 'AnnArg $(textToStrLit sn) $(textToStrLit mn) $(textToStrLit an) $(pure dv) |]

-- | Reads a GraphQL 'TypeDefinition' and returns a 'Result'.
typeToDec :: Name -> TypeMap -> SchemaMap -> GQL.TypeDefinition -> Q Result
typeToDec :: Name -> TypeMap -> SchemaMap -> TypeDefinition -> Q Result
typeToDec Name
_ TypeMap
_ SchemaMap
_ (GQL.TypeDefinitionInterface InterfaceTypeDefinition
_)
  = String -> Q Result
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"interface types are not supported"
typeToDec Name
_ TypeMap
_ SchemaMap
_ (GQL.TypeDefinitionUnion UnionTypeDefinition
_)
  = String -> Q Result
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"union types are not supported"
typeToDec Name
schemaName TypeMap
tm SchemaMap
_ (GQL.TypeDefinitionScalar (GQL.ScalarTypeDefinition Maybe Description
_ Name
s [Directive]
_)) =
  Result
GQLScalar Result -> TypeQ -> Q Result
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> TypeMap -> Name -> TypeQ
gqlTypeToType Name
s TypeMap
tm Name
schemaName
typeToDec Name
schemaName TypeMap
tm SchemaMap
sm (GQL.TypeDefinitionObject ObjectTypeDefinition
objs) = ObjectTypeDefinition -> Q Result
objToDec ObjectTypeDefinition
objs
  where
    objToDec :: GQL.ObjectTypeDefinition -> Q Result
    objToDec :: ObjectTypeDefinition -> Q Result
objToDec (GQL.ObjectTypeDefinition Maybe Description
_ (Name -> Text
coerce -> Text
nm) [NamedType]
_ [Directive]
_ [FieldDefinition]
flds) = do
      ([Type]
fieldInfos, [[(Text, (Text, Type))]]
defaults) <- [(Type, [(Text, (Text, Type))])]
-> ([Type], [[(Text, (Text, Type))]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Type, [(Text, (Text, Type))])]
 -> ([Type], [[(Text, (Text, Type))]]))
-> Q [(Type, [(Text, (Text, Type))])]
-> Q ([Type], [[(Text, (Text, Type))]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldDefinition -> Q (Type, [(Text, (Text, Type))]))
-> [FieldDefinition] -> Q [(Type, [(Text, (Text, Type))])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Text -> FieldDefinition -> Q (Type, [(Text, (Text, Type))])
gqlFieldToType Text
nm) [FieldDefinition]
flds
      Type -> [(Text, (Text, (Text, Type)))] -> Result
GQLService (Type -> [(Text, (Text, (Text, Type)))] -> Result)
-> TypeQ -> Q ([(Text, (Text, (Text, Type)))] -> Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| 'Service $(textToStrLit nm)
                                  $(pure $ typesToList fieldInfos) |]
                 Q ([(Text, (Text, (Text, Type)))] -> Result)
-> Q [(Text, (Text, (Text, Type)))] -> Q Result
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(Text, (Text, (Text, Type)))] -> Q [(Text, (Text, (Text, Type)))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Text
nm,) ((Text, (Text, Type)) -> (Text, (Text, (Text, Type))))
-> [(Text, (Text, Type))] -> [(Text, (Text, (Text, Type)))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(Text, (Text, Type))]] -> [(Text, (Text, Type))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Text, (Text, Type))]]
defaults)
    gqlFieldToType :: T.Text -> GQL.FieldDefinition
                   -> Q (Type, [(T.Text, (T.Text, Type))])
    gqlFieldToType :: Text -> FieldDefinition -> Q (Type, [(Text, (Text, Type))])
gqlFieldToType Text
sn (GQL.FieldDefinition Maybe Description
_ (Name -> Text
coerce -> Text
fnm) [InputValueDefinition]
args GType
ftyp [Directive]
_) = do
      ([Type]
argInfos, [Maybe (Text, Type)]
defaults) <- [(Type, Maybe (Text, Type))] -> ([Type], [Maybe (Text, Type)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Type, Maybe (Text, Type))] -> ([Type], [Maybe (Text, Type)]))
-> Q [(Type, Maybe (Text, Type))]
-> Q ([Type], [Maybe (Text, Type)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (InputValueDefinition -> Q (Type, Maybe (Text, Type)))
-> [InputValueDefinition] -> Q [(Type, Maybe (Text, Type))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse InputValueDefinition -> Q (Type, Maybe (Text, Type))
argToType [InputValueDefinition]
args
      (,) (Type -> [(Text, (Text, Type))] -> (Type, [(Text, (Text, Type))]))
-> TypeQ
-> Q ([(Text, (Text, Type))] -> (Type, [(Text, (Text, Type))]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| 'Method $(textToStrLit fnm)
                          $(pure $ typesToList argInfos)
                          $(returnType sn ftyp) |]
          Q ([(Text, (Text, Type))] -> (Type, [(Text, (Text, Type))]))
-> Q [(Text, (Text, Type))] -> Q (Type, [(Text, (Text, Type))])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(Text, (Text, Type))] -> Q [(Text, (Text, Type))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Text
fnm,) ((Text, Type) -> (Text, (Text, Type)))
-> [(Text, Type)] -> [(Text, (Text, Type))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe (Text, Type)] -> [(Text, Type)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Text, Type)]
defaults)
    returnType :: T.Text -> GQL.GType -> Q Type
    returnType :: Text -> GType -> TypeQ
returnType Text
serviceName GType
typ =
      case Text -> SchemaMap -> Maybe OperationType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
serviceName SchemaMap
sm of
        Just OperationType
GQL.OperationTypeSubscription -> [t|'RetStream $(retToType typ)|]
        Maybe OperationType
_                                  -> [t|'RetSingle $(retToType typ)|]
    argToType :: GQL.InputValueDefinition -> Q (Type, Maybe (T.Text, Type))
    argToType :: InputValueDefinition -> Q (Type, Maybe (Text, Type))
argToType (GQL.InputValueDefinition Maybe Description
_ (Name -> Text
coerce -> Text
aname) GType
atype Maybe DefaultValue
Nothing) =
      (, Maybe (Text, Type)
forall a. Maybe a
Nothing) (Type -> (Type, Maybe (Text, Type)))
-> TypeQ -> Q (Type, Maybe (Text, Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| 'ArgSingle ('Just $(textToStrLit aname)) $(retToType atype) |]
    argToType (GQL.InputValueDefinition Maybe Description
_ (Name -> Text
coerce -> Text
aname) GType
atype (Just DefaultValue
defs)) =
      (,) (Type -> Maybe (Text, Type) -> (Type, Maybe (Text, Type)))
-> TypeQ -> Q (Maybe (Text, Type) -> (Type, Maybe (Text, Type)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| 'ArgSingle ('Just $(textToStrLit aname)) $(retToType atype) |]
          Q (Maybe (Text, Type) -> (Type, Maybe (Text, Type)))
-> Q (Maybe (Text, Type)) -> Q (Type, Maybe (Text, Type))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Text, Type) -> Maybe (Text, Type)
forall a. a -> Maybe a
Just ((Text, Type) -> Maybe (Text, Type))
-> (Type -> (Text, Type)) -> Type -> Maybe (Text, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
aname,) (Type -> Maybe (Text, Type)) -> TypeQ -> Q (Maybe (Text, Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| 'DefaultValue $( defToVConst defs ) |])
    defToVConst :: GQL.DefaultValue -> Q Type
    defToVConst :: DefaultValue -> TypeQ
defToVConst (GQL.VCBoolean Bool
_) = [t| 'VCBoolean|]
    defToVConst DefaultValue
GQL.VCNull        = [t| 'VCNull |]
    defToVConst (GQL.VCInt Integer
_)     = [t| 'VCInt |]
    defToVConst (GQL.VCFloat Scientific
_)
      = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"floats as default arguments are not supported"
    defToVConst (GQL.VCString (StringValue -> Text
coerce -> Text
s))
      = [t| 'VCString $(textToStrLit s) |]
    defToVConst (GQL.VCEnum (EnumValue -> Text
coerce -> Text
e))
      = [t| 'VCEnum $(textToStrLit e) |]
    defToVConst (GQL.VCList (GQL.ListValueG [DefaultValue]
xs))
      = [t| 'VCList $(typesToList <$> traverse defToVConst xs) |]
    defToVConst (GQL.VCObject (GQL.ObjectValueG [ObjectFieldG DefaultValue]
obj))
      = [t| 'VCObject $(typesToList <$> traverse fromGQLField obj) |]
    fromGQLField :: GQL.ObjectFieldG GQL.ValueConst -> Q Type
    fromGQLField :: ObjectFieldG DefaultValue -> TypeQ
fromGQLField (GQL.ObjectFieldG (Name -> Text
coerce -> Text
n) DefaultValue
v)   = [t| ($(textToStrLit n), $(defToVConst v)) |]
    retToType :: GQL.GType -> Q Type
    retToType :: GType -> TypeQ
retToType (GQL.TypeNamed (Nullability -> Bool
coerce -> Bool
False) (NamedType -> Name
coerce -> Name
a)) =
      [t| $(gqlTypeToType a tm schemaName) |]
    retToType (GQL.TypeNamed (Nullability -> Bool
coerce -> Bool
True) (NamedType -> Name
coerce -> Name
a)) =
      [t| 'OptionalRef $(gqlTypeToType a tm schemaName) |]
    retToType (GQL.TypeList (Nullability -> Bool
coerce -> Bool
False) (ListType -> GType
coerce -> GType
a)) =
      [t| 'ListRef $(retToType a) |]
    retToType (GQL.TypeList (Nullability -> Bool
coerce -> Bool
True) (ListType -> GType
coerce -> GType
a)) =
      [t| 'OptionalRef ('ListRef $(retToType a)) |]
    retToType GType
_ = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"this should not happen, please, file an issue"
typeToDec Name
_ TypeMap
_ SchemaMap
_ (GQL.TypeDefinitionEnum EnumTypeDefinition
enums)        = EnumTypeDefinition -> Q Result
enumToDecl EnumTypeDefinition
enums
  where
    enumToDecl :: GQL.EnumTypeDefinition -> Q Result
    enumToDecl :: EnumTypeDefinition -> Q Result
enumToDecl (GQL.EnumTypeDefinition Maybe Description
_ (Name -> Text
coerce -> Text
name) [Directive]
_ [EnumValueDefinition]
symbols) =
      Type -> Result
GQLSchema (Type -> Result) -> TypeQ -> Q Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|'DEnum $(textToStrLit name)
                              $(typesToList <$> traverse gqlChoiceToType symbols)|]
    gqlChoiceToType :: GQL.EnumValueDefinition -> Q Type
    gqlChoiceToType :: EnumValueDefinition -> TypeQ
gqlChoiceToType (GQL.EnumValueDefinition Maybe Description
_ (EnumValue -> Text
coerce -> Text
c) [Directive]
_) =
      [t|'ChoiceDef $(textToStrLit c)|]
typeToDec Name
_ TypeMap
_ SchemaMap
_ (GQL.TypeDefinitionInputObject InputObjectTypeDefinition
inpts) = InputObjectTypeDefinition -> Q Result
inputObjToDec InputObjectTypeDefinition
inpts
  where
    inputObjToDec :: GQL.InputObjectTypeDefinition -> Q Result
    inputObjToDec :: InputObjectTypeDefinition -> Q Result
inputObjToDec (GQL.InputObjectTypeDefinition Maybe Description
_ (Name -> Text
coerce -> Text
name) [Directive]
_ [InputValueDefinition]
fields) =
        Type -> Result
GQLSchema (Type -> Result) -> TypeQ -> Q Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|'DRecord $(textToStrLit name)
                                  $(typesToList <$> traverse gqlFieldToType fields)|]
    gqlFieldToType :: GQL.InputValueDefinition -> Q Type
    gqlFieldToType :: InputValueDefinition -> TypeQ
gqlFieldToType (GQL.InputValueDefinition Maybe Description
_ (Name -> Text
coerce -> Text
fname) GType
ftype Maybe DefaultValue
_) =
      [t|'FieldDef $(textToStrLit fname) $(ginputTypeToType ftype)|]
    ginputTypeToType :: GQL.GType -> Q Type
    ginputTypeToType :: GType -> TypeQ
ginputTypeToType (GQL.TypeNamed (Nullability -> Bool
coerce -> Bool
False) (NamedType -> Name
coerce -> Name
a)) =
      [t| $(typeToPrimType a) |]
    ginputTypeToType (GQL.TypeNamed (Nullability -> Bool
coerce -> Bool
True) (NamedType -> Name
coerce -> Name
a)) =
      [t| 'OptionalRef $(typeToPrimType a) |]
    ginputTypeToType (GQL.TypeList (Nullability -> Bool
coerce -> Bool
False) (ListType -> GType
coerce -> GType
a)) =
      [t| 'ListRef $(ginputTypeToType a) |]
    ginputTypeToType (GQL.TypeList (Nullability -> Bool
coerce -> Bool
True) (ListType -> GType
coerce -> GType
a)) =
      [t| 'OptionalRef ('ListRef $(ginputTypeToType a)) |]
    ginputTypeToType GType
_ = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"this should not happen, please, file an issue"
    typeToPrimType :: GQL.Name -> Q Type
    typeToPrimType :: Name -> TypeQ
typeToPrimType (Name -> Text
GQL.unName -> Text
"Int")     = [t|'TPrimitive Integer|]
    typeToPrimType (Name -> Text
GQL.unName -> Text
"Float")   = [t|'TPrimitive Double|]
    typeToPrimType (Name -> Text
GQL.unName -> Text
"String")  = [t|'TPrimitive T.Text|]
    typeToPrimType (Name -> Text
GQL.unName -> Text
"Boolean") = [t|'TPrimitive Bool|]
    typeToPrimType (Name -> Text
GQL.unName -> Text
"ID")      = [t|'TPrimitive UUID|]
    typeToPrimType (Name -> Text
coerce -> Text
name)          = [t|'TSchematic $(textToStrLit name)|]

gqlTypeToType :: GQL.Name -> TypeMap -> Name -> Q Type
gqlTypeToType :: Name -> TypeMap -> Name -> TypeQ
gqlTypeToType (Name -> Text
GQL.unName -> Text
"Int") TypeMap
_  Name
_     = [t|'PrimitiveRef Integer|]
gqlTypeToType (Name -> Text
GQL.unName -> Text
"Float") TypeMap
_ Name
_    = [t|'PrimitiveRef Double|]
gqlTypeToType (Name -> Text
GQL.unName -> Text
"String") TypeMap
_ Name
_   = [t|'PrimitiveRef T.Text|]
gqlTypeToType (Name -> Text
GQL.unName -> Text
"Boolean") TypeMap
_ Name
_  = [t|'PrimitiveRef Bool|]
gqlTypeToType (Name -> Text
GQL.unName -> Text
"ID") TypeMap
_ Name
_       = [t|'PrimitiveRef UUID|]
gqlTypeToType (Name -> Text
coerce -> Text
name) TypeMap
tm Name
schemaName =
  let schemaRef :: TypeQ
schemaRef = [t|'SchemaRef $(conT schemaName) $(textToStrLit name)|]
   in case Text -> TypeMap -> Maybe GQLType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
name TypeMap
tm of
        Just GQLType
Enum        -> TypeQ
schemaRef
        Just GQLType
InputObject -> TypeQ
schemaRef
        Maybe GQLType
_                -> [t|'ObjectRef $(textToStrLit name)|]

typesToList :: [Type] -> Type
typesToList :: [Type] -> Type
typesToList = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
PromotedConsT) Type
PromotedNilT

textToStrLit :: T.Text -> Q Type
textToStrLit :: Text -> TypeQ
textToStrLit = TyLitQ -> TypeQ
litT (TyLitQ -> TypeQ) -> (Text -> TyLitQ) -> Text -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TyLitQ
strTyLit (String -> TyLitQ) -> (Text -> String) -> Text -> TyLitQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack