{-# 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
, Primitives
, graphqlWithExtendedPrimitives
, graphql'
) where

import           Control.Monad.IO.Class      (liftIO)
import qualified Data.Aeson                  as JSON
import           Data.Foldable               (toList)
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.AST        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 = Primitives -> 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.
graphqlWithExtendedPrimitives
        :: Primitives
        -> String   -- ^ Name for the 'Package' type, the 'Schema' is derived from it
        -> FilePath -- ^ Route to the file
        -> Q [Dec]
graphqlWithExtendedPrimitives :: Primitives -> String -> String -> Q [Dec]
graphqlWithExtendedPrimitives Primitives
prims String
name = Primitives -> String -> String -> String -> Q [Dec]
graphql' Primitives
prims (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' :: Primitives
         -> String   -- ^ Name for the 'Schema' type
         -> String   -- ^ Name for the 'Package' type
         -> FilePath -- ^ Route to the file
         -> Q [Dec]
graphql' :: Primitives -> String -> String -> String -> Q [Dec]
graphql' Primitives
prims 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 -> Primitives -> String -> String -> [TypeSystemDefinition] -> Q [Dec]
graphqlToDecls (Primitives
basicPrimitives Primitives -> Primitives -> Primitives
forall a. Semigroup a => a -> a -> a
<> Primitives
prims) String
scName String
svName [TypeSystemDefinition]
p

type Primitives = [(GQL.Name, TypeQ)]

basicPrimitives :: Primitives
basicPrimitives :: Primitives
basicPrimitives
  = [ (Text
"Int",        [t|Integer|])
    , (Text
"Float",      [t|Double|])
    , (Text
"String",     [t|T.Text|])
    , (Text
"Boolean",    [t|Bool|])
    , (Text
"UUID",       [t|UUID|])
    , (Text
"JSON",       [t|JSON.Value|])
    , (Text
"JSONObject", [t|JSON.Object|])]

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
  | Union
  | Interface

classifySchema :: [GQL.TypeSystemDefinition] -> SchemaMap
classifySchema :: [TypeSystemDefinition] -> SchemaMap
classifySchema = (SchemaMap -> TypeSystemDefinition -> SchemaMap)
-> SchemaMap -> [TypeSystemDefinition] -> SchemaMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SchemaMap -> TypeSystemDefinition -> SchemaMap
schemaToMap SchemaMap
forall k v. HashMap k v
HM.empty
  where
    schemaToMap :: SchemaMap -> GQL.TypeSystemDefinition -> SchemaMap
    schemaToMap :: SchemaMap -> TypeSystemDefinition -> SchemaMap
schemaToMap SchemaMap
mp (GQL.SchemaDefinition [Directive]
_ (NonEmpty OperationTypeDefinition -> [OperationTypeDefinition]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> [OperationTypeDefinition]
ops)) = (SchemaMap -> OperationTypeDefinition -> SchemaMap)
-> SchemaMap -> [OperationTypeDefinition] -> SchemaMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SchemaMap -> OperationTypeDefinition -> SchemaMap
operationToKeyValue SchemaMap
mp [OperationTypeDefinition]
ops
    schemaToMap SchemaMap
_ TypeSystemDefinition
_ = String -> SchemaMap
forall a. HasCallStack => String -> a
error String
"this should have been taken care by graphqlToDecls"
    operationToKeyValue :: SchemaMap -> GQL.OperationTypeDefinition -> SchemaMap
    operationToKeyValue :: SchemaMap -> OperationTypeDefinition -> SchemaMap
operationToKeyValue SchemaMap
mp (GQL.OperationTypeDefinition OperationType
opType 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.ScalarTypeDefinition Description
_ Text
name [Directive]
_)
      = (Text
name, GQLType
Scalar)
    typeToKeyValue (GQL.ObjectTypeDefinition Description
_ Text
name ImplementsInterfaces []
_ [Directive]
_ [FieldDefinition]
_)
      = (Text
name, GQLType
Object)
    typeToKeyValue (GQL.InterfaceTypeDefinition Description
_ Text
name [Directive]
_ [FieldDefinition]
_)
      = (Text
name, GQLType
Interface)
    typeToKeyValue (GQL.UnionTypeDefinition Description
_ Text
name [Directive]
_ UnionMemberTypes []
_)
      = (Text
name, GQLType
Union)
    typeToKeyValue (GQL.EnumTypeDefinition Description
_ Text
name [Directive]
_ [EnumValueDefinition]
_)
      = (Text
name, GQLType
Enum)
    typeToKeyValue (GQL.InputObjectTypeDefinition Description
_ Text
name [Directive]
_ [InputValueDefinition]
_)
      = (Text
name, GQLType
InputObject)

-- | Constructs the GraphQL tree splitting between Schemas and Services.
graphqlToDecls
  :: Primitives
  -> String -> String
  -> [GQL.TypeSystemDefinition] -> Q [Dec]
graphqlToDecls :: Primitives -> String -> String -> [TypeSystemDefinition] -> Q [Dec]
graphqlToDecls Primitives
prims 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.TypeDefinition TypeDefinition
t <- [TypeSystemDefinition]
allTypes]
      schTypes :: [TypeSystemDefinition]
schTypes     = [TypeSystemDefinition
t | t :: TypeSystemDefinition
t@GQL.SchemaDefinition {} <- [TypeSystemDefinition]
allTypes]
      typeMap :: TypeMap
typeMap      = [TypeDefinition] -> TypeMap
classify [TypeDefinition]
types
      schMap :: SchemaMap
schMap       = [TypeSystemDefinition] -> SchemaMap
classifySchema [TypeSystemDefinition]
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 (Primitives
-> Name -> TypeMap -> SchemaMap -> TypeDefinition -> Q Result
typeToDec Primitives
prims 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 :: Primitives
          -> Name -> TypeMap -> SchemaMap
          -> GQL.TypeDefinition -> Q Result
typeToDec :: Primitives
-> Name -> TypeMap -> SchemaMap -> TypeDefinition -> Q Result
typeToDec Primitives
_ Name
_ TypeMap
_ SchemaMap
_ GQL.InterfaceTypeDefinition {}
  = String -> Q Result
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"interface types are not supported"
typeToDec Primitives
_ Name
_ TypeMap
_ SchemaMap
_ (GQL.UnionTypeDefinition Description
_ Text
nm [Directive]
_ (GQL.UnionMemberTypes [Text]
elts)) = do
  [Type]
selts <- (Text -> TypeQ) -> [Text] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> TypeQ
textToStrLit [Text]
elts
  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| 'OneOf $(textToStrLit nm)
                            $(pure $ typesToList selts) |]
             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 []
typeToDec Primitives
prims Name
schemaName TypeMap
tm SchemaMap
_ (GQL.ScalarTypeDefinition Description
_ Text
s [Directive]
_) =
  Result
GQLScalar Result -> TypeQ -> Q Result
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Primitives -> Text -> TypeMap -> Name -> TypeQ
gqlTypeToType Primitives
prims Text
s TypeMap
tm Name
schemaName
typeToDec Primitives
prims Name
schemaName TypeMap
tm SchemaMap
sm (GQL.ObjectTypeDefinition Description
_ Text
nm ImplementsInterfaces []
_ [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)
  where
    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 Description
_ Text
fnm (GQL.ArgumentsDefinition [InputValueDefinition]
args) Type
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.Type -> Q Type
    returnType :: Text -> Type -> TypeQ
returnType Text
serviceName Type
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.Subscription -> [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 Description
_ Text
aname Type
atype Maybe (Node ConstValue)
Nothing [Directive]
_) =
      (, 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 Description
_ Text
aname Type
atype (Just (GQL.Node ConstValue
defs Location
_)) [Directive]
_) =
      (,) (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.ConstValue -> Q Type
    defToVConst :: ConstValue -> TypeQ
defToVConst (GQL.ConstBoolean Bool
_) = [t| 'VCBoolean|]
    defToVConst ConstValue
GQL.ConstNull        = [t| 'VCNull |]
    defToVConst (GQL.ConstInt Int32
_)     = [t| 'VCInt |]
    defToVConst (GQL.ConstFloat Double
_)
      = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"floats as default arguments are not supported"
    defToVConst (GQL.ConstString Text
s)
      = [t| 'VCString $(textToStrLit s) |]
    defToVConst (GQL.ConstEnum Text
e)
      = [t| 'VCEnum $(textToStrLit e) |]
    defToVConst (GQL.ConstList [Node ConstValue]
xs)
      = [t| 'VCList $(typesToList <$> traverse (defToVConst . GQL.node) xs) |]
    defToVConst (GQL.ConstObject [ObjectField ConstValue]
obj)
      = [t| 'VCObject $(typesToList <$> traverse fromGQLField obj) |]
    fromGQLField :: GQL.ObjectField GQL.ConstValue -> Q Type
    fromGQLField :: ObjectField ConstValue -> TypeQ
fromGQLField (GQL.ObjectField Text
n (GQL.Node ConstValue
v Location
_) Location
_) = [t| ($(textToStrLit n), $(defToVConst v)) |]
    retToType :: GQL.Type -> Q Type
    retToType :: Type -> TypeQ
retToType (GQL.TypeNonNull (GQL.NonNullTypeNamed Text
a)) =
      [t| $(gqlTypeToType prims a tm schemaName) |]
    retToType (GQL.TypeNonNull (GQL.NonNullTypeList Type
a)) =
      [t| 'ListRef $(retToType a) |]
    retToType (GQL.TypeNamed Text
a) =
      [t| 'OptionalRef $(gqlTypeToType prims a tm schemaName) |]
    retToType (GQL.TypeList Type
a) =
      [t| 'OptionalRef ('ListRef $(retToType a)) |]
typeToDec Primitives
_ Name
_ TypeMap
_ SchemaMap
_ (GQL.EnumTypeDefinition Description
_ 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)|]
  where
    gqlChoiceToType :: GQL.EnumValueDefinition -> Q Type
    gqlChoiceToType :: EnumValueDefinition -> TypeQ
gqlChoiceToType (GQL.EnumValueDefinition Description
_ Text
c [Directive]
_) =
      [t|'ChoiceDef $(textToStrLit c)|]
typeToDec Primitives
prims Name
_ TypeMap
_ SchemaMap
_ (GQL.InputObjectTypeDefinition Description
_ 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)|]
  where
    gqlFieldToType :: GQL.InputValueDefinition -> Q Type
    gqlFieldToType :: InputValueDefinition -> TypeQ
gqlFieldToType (GQL.InputValueDefinition Description
_ Text
fname Type
ftype Maybe (Node ConstValue)
_ [Directive]
_) =
      [t|'FieldDef $(textToStrLit fname) $(ginputTypeToType ftype)|]
    ginputTypeToType :: GQL.Type -> Q Type
    ginputTypeToType :: Type -> TypeQ
ginputTypeToType (GQL.TypeNonNull (GQL.NonNullTypeNamed Text
a)) =
      [t| $(typeToPrimType a) |]
    ginputTypeToType (GQL.TypeNonNull (GQL.NonNullTypeList Type
a)) =
      [t| 'TList $(ginputTypeToType a) |]
    ginputTypeToType (GQL.TypeNamed Text
a) =
      [t| 'TOption $(typeToPrimType a) |]
    ginputTypeToType (GQL.TypeList Type
a) =
      [t| 'TOption ('TList $(ginputTypeToType a)) |]
    typeToPrimType :: GQL.Name -> Q Type
    typeToPrimType :: Text -> TypeQ
typeToPrimType Text
nm
      = case Text -> Primitives -> Maybe TypeQ
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
nm Primitives
prims of
          Just TypeQ
ty -> [t|'TPrimitive $ty|]
          Maybe TypeQ
Nothing -> [t|'TSchematic $(textToStrLit nm)|]

-- For the JSON scalar we follow
-- https://github.com/taion/graphql-type-json

gqlTypeToType :: Primitives -> GQL.Name -> TypeMap -> Name -> Q Type
gqlTypeToType :: Primitives -> Text -> TypeMap -> Name -> TypeQ
gqlTypeToType Primitives
prims Text
name TypeMap
tm Name
schemaName
  = case Text -> Primitives -> Maybe TypeQ
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
name Primitives
prims of
      Just TypeQ
ty -> [t|'PrimitiveRef $ty|]
      Maybe TypeQ
Nothing
        -> 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