{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.CodeGen.Server.Interpreting.Directive
  ( getDirs,
    getNamespaceDirs,
    dirRename,
  )
where

import Data.Char (isUpper)
import Data.Morpheus.CodeGen.Internal.AST
  ( getFullName,
  )
import Data.Morpheus.CodeGen.Server.Internal.AST (ServerDirectiveUsage (..), TypeValue (..), unpackName)
import Data.Morpheus.CodeGen.Server.Interpreting.Utils
  ( CodeGenT,
    TypeContext (..),
    getEnumName,
    getFieldName,
    inType,
    lookupFieldType,
  )
import Data.Morpheus.Core (internalSchema, render)
import Data.Morpheus.Internal.Utils (IsMap, selectOr)
import Data.Morpheus.Types.Internal.AST
  ( Argument (..),
    ArgumentDefinition (..),
    CONST,
    DataEnumValue (..),
    Description,
    Directive (Directive, directiveArgs, directiveName),
    DirectiveDefinition (..),
    FieldDefinition (..),
    FieldName,
    FieldsDefinition,
    Name,
    ObjectEntry (..),
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    TypeRef (..),
  )
import qualified Data.Morpheus.Types.Internal.AST as AST
import Data.Text (head)
import Relude hiding (ByteString, get, head)

getNamespaceDirs :: MonadReader (TypeContext s) m => Text -> m [ServerDirectiveUsage]
getNamespaceDirs :: forall (s :: Stage) (m :: * -> *).
MonadReader (TypeContext s) m =>
Text -> m [ServerDirectiveUsage]
getNamespaceDirs Text
genTypeName = do
  Bool
namespaces <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage). TypeContext s -> Bool
hasNamespace
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [TypeValue -> ServerDirectiveUsage
TypeDirectiveUsage (Text -> TypeValue
dirDropNamespace Text
genTypeName) | Bool
namespaces]

descDirective :: Maybe Description -> [TypeValue]
descDirective :: Maybe Text -> [TypeValue]
descDirective Maybe Text
desc = forall a b. (a -> b) -> [a] -> [b]
map Text -> TypeValue
describe (forall a. Maybe a -> [a]
maybeToList Maybe Text
desc)
  where
    describe :: Text -> TypeValue
describe Text
x = TypeName -> [(FieldName, TypeValue)] -> TypeValue
TypeValueObject TypeName
"Describe" [(FieldName
"text", Text -> TypeValue
TypeValueString Text
x)]

dirDropNamespace :: Text -> TypeValue
dirDropNamespace :: Text -> TypeValue
dirDropNamespace Text
name = TypeName -> [(FieldName, TypeValue)] -> TypeValue
TypeValueObject TypeName
"DropNamespace" [(FieldName
"dropNamespace", Text -> TypeValue
TypeValueString Text
name)]

dirRename :: Name t -> TypeValue
dirRename :: forall (t :: NAME). Name t -> TypeValue
dirRename Name t
name = TypeName -> [(FieldName, TypeValue)] -> TypeValue
TypeValueObject TypeName
"Rename" [(FieldName
"newName", Text -> TypeValue
TypeValueString (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName Name t
name))]

class Meta a where
  getDirs :: MonadFail m => a -> CodeGenT m [ServerDirectiveUsage]

instance (Meta a) => Meta (Maybe a) where
  getDirs :: forall (m :: * -> *).
MonadFail m =>
Maybe a -> CodeGenT m [ServerDirectiveUsage]
getDirs (Just a
x) = forall a (m :: * -> *).
(Meta a, MonadFail m) =>
a -> CodeGenT m [ServerDirectiveUsage]
getDirs a
x
  getDirs Maybe a
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []

instance Meta (TypeDefinition c CONST) where
  getDirs :: forall (m :: * -> *).
MonadFail m =>
TypeDefinition c CONST -> CodeGenT m [ServerDirectiveUsage]
getDirs TypeDefinition {TypeContent TRUE c CONST
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent :: TypeContent TRUE c CONST
typeContent, Directives CONST
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
typeDirectives :: Directives CONST
typeDirectives, Maybe Text
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Text
typeDescription :: Maybe Text
typeDescription} = do
    [ServerDirectiveUsage]
contentD <- forall a (m :: * -> *).
(Meta a, MonadFail m) =>
a -> CodeGenT m [ServerDirectiveUsage]
getDirs TypeContent TRUE c CONST
typeContent
    [ServerDirectiveUsage]
typeD <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *}.
MonadFail m =>
Directive CONST
-> ReaderT (TypeContext CONST) m ServerDirectiveUsage
transform (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Directives CONST
typeDirectives)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ServerDirectiveUsage]
contentD forall a. Semigroup a => a -> a -> a
<> [ServerDirectiveUsage]
typeD forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map TypeValue -> ServerDirectiveUsage
TypeDirectiveUsage (Maybe Text -> [TypeValue]
descDirective Maybe Text
typeDescription))
    where
      transform :: Directive CONST
-> ReaderT (TypeContext CONST) m ServerDirectiveUsage
transform Directive CONST
v = TypeValue -> ServerDirectiveUsage
TypeDirectiveUsage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadFail m =>
Directive CONST -> CodeGenT m TypeValue
directiveTypeValue Directive CONST
v

instance Meta (TypeContent a c CONST) where
  getDirs :: forall (m :: * -> *).
MonadFail m =>
TypeContent a c CONST -> CodeGenT m [ServerDirectiveUsage]
getDirs DataObject {FieldsDefinition OUT CONST
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT CONST
objectFields} = forall a (m :: * -> *).
(Meta a, MonadFail m) =>
a -> CodeGenT m [ServerDirectiveUsage]
getDirs FieldsDefinition OUT CONST
objectFields
  getDirs DataInputObject {FieldsDefinition IN CONST
inputObjectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent INPUT_OBJECT a s -> FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN CONST
inputObjectFields} = forall a (m :: * -> *).
(Meta a, MonadFail m) =>
a -> CodeGenT m [ServerDirectiveUsage]
getDirs FieldsDefinition IN CONST
inputObjectFields
  getDirs DataInterface {FieldsDefinition OUT CONST
interfaceFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent IMPLEMENTABLE a s -> FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT CONST
interfaceFields} = forall a (m :: * -> *).
(Meta a, MonadFail m) =>
a -> CodeGenT m [ServerDirectiveUsage]
getDirs FieldsDefinition OUT CONST
interfaceFields
  getDirs DataEnum {DataEnum CONST
enumMembers :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent LEAF a s -> DataEnum s
enumMembers :: DataEnum CONST
enumMembers} = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(Meta a, MonadFail m) =>
a -> CodeGenT m [ServerDirectiveUsage]
getDirs DataEnum CONST
enumMembers
  getDirs TypeContent a c CONST
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []

instance Meta (DataEnumValue CONST) where
  getDirs :: forall (m :: * -> *).
MonadFail m =>
DataEnumValue CONST -> CodeGenT m [ServerDirectiveUsage]
getDirs DataEnumValue {TypeName
enumName :: forall (s :: Stage). DataEnumValue s -> TypeName
enumName :: TypeName
enumName, Directives CONST
enumDirectives :: forall (s :: Stage). DataEnumValue s -> Directives s
enumDirectives :: Directives CONST
enumDirectives, Maybe Text
enumDescription :: forall (s :: Stage). DataEnumValue s -> Maybe Text
enumDescription :: Maybe Text
enumDescription} = do
    [TypeValue]
dirs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
MonadFail m =>
Directive CONST -> CodeGenT m TypeValue
directiveTypeValue (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Directives CONST
enumDirectives)
    TypeName
name <- CodeGenTypeName -> TypeName
getFullName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (s :: Stage) (m :: * -> *).
MonadReader (TypeContext s) m =>
TypeName -> m CodeGenTypeName
getEnumName TypeName
enumName
    let renameEnum :: [ServerDirectiveUsage]
renameEnum = [TypeName -> TypeValue -> ServerDirectiveUsage
EnumDirectiveUsage TypeName
name (forall (t :: NAME). Name t -> TypeValue
dirRename TypeName
enumName) | Bool -> Bool
not (forall (t :: NAME). Name t -> Bool
isUpperCase TypeName
enumName)]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [ServerDirectiveUsage]
renameEnum forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map (TypeName -> TypeValue -> ServerDirectiveUsage
EnumDirectiveUsage TypeName
name) ([TypeValue]
dirs forall a. Semigroup a => a -> a -> a
<> Maybe Text -> [TypeValue]
descDirective Maybe Text
enumDescription)

instance Meta (FieldsDefinition c CONST) where
  getDirs :: forall (m :: * -> *).
MonadFail m =>
FieldsDefinition c CONST -> CodeGenT m [ServerDirectiveUsage]
getDirs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(Meta a, MonadFail m) =>
a -> CodeGenT m [ServerDirectiveUsage]
getDirs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance Meta (FieldDefinition c CONST) where
  getDirs :: forall (m :: * -> *).
MonadFail m =>
FieldDefinition c CONST -> CodeGenT m [ServerDirectiveUsage]
getDirs FieldDefinition {FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName, Directives CONST
fieldDirectives :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Directives s
fieldDirectives :: Directives CONST
fieldDirectives, Maybe Text
fieldDescription :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe Text
fieldDescription :: Maybe Text
fieldDescription} = do
    [TypeValue]
dirs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
MonadFail m =>
Directive CONST -> CodeGenT m TypeValue
directiveTypeValue (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Directives CONST
fieldDirectives)
    FieldName
name <- forall (m :: * -> *). Monad m => FieldName -> CodeGenT m FieldName
getFieldName FieldName
fieldName
    let renameField :: [ServerDirectiveUsage]
renameField = [FieldName -> TypeValue -> ServerDirectiveUsage
FieldDirectiveUsage FieldName
name (forall (t :: NAME). Name t -> TypeValue
dirRename FieldName
fieldName) | forall (t :: NAME). Name t -> Bool
isUpperCase FieldName
fieldName]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [ServerDirectiveUsage]
renameField forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map (FieldName -> TypeValue -> ServerDirectiveUsage
FieldDirectiveUsage FieldName
name) ([TypeValue]
dirs forall a. Semigroup a => a -> a -> a
<> Maybe Text -> [TypeValue]
descDirective Maybe Text
fieldDescription)

directiveTypeValue :: MonadFail m => Directive CONST -> CodeGenT m TypeValue
directiveTypeValue :: forall (m :: * -> *).
MonadFail m =>
Directive CONST -> CodeGenT m TypeValue
directiveTypeValue Directive {FieldName
Position
Arguments CONST
directivePosition :: forall (s :: Stage). Directive s -> Position
directiveArgs :: Arguments CONST
directiveName :: FieldName
directivePosition :: Position
directiveName :: forall (s :: Stage). Directive s -> FieldName
directiveArgs :: forall (s :: Stage). Directive s -> Arguments s
..} = forall (s :: Stage) (m :: * -> *) a.
MonadReader (TypeContext s) m =>
Maybe TypeName -> m a -> m a
inType Maybe TypeName
typeContext forall a b. (a -> b) -> a -> b
$ do
  DirectiveDefinition CONST
dirs <- forall (m :: * -> *).
(MonadReader (TypeContext CONST) m, MonadFail m) =>
FieldName -> m (DirectiveDefinition CONST)
getDirective FieldName
directiveName
  TypeName -> [(FieldName, TypeValue)] -> TypeValue
TypeValueObject TypeName
typename forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (c :: * -> *) (m :: * -> *) (s :: Stage).
(IsMap FieldName c, MonadFail m) =>
c (Argument CONST)
-> ArgumentDefinition s
-> ReaderT (TypeContext CONST) m (FieldName, TypeValue)
renderArgumentValue Arguments CONST
directiveArgs) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall (s :: Stage). DirectiveDefinition s -> ArgumentsDefinition s
directiveDefinitionArgs DirectiveDefinition CONST
dirs)
  where
    (Maybe TypeName
typeContext, TypeName
typename) = FieldName -> (Maybe TypeName, TypeName)
renderDirectiveTypeName FieldName
directiveName

nativeDirectives :: AST.DirectivesDefinition CONST
nativeDirectives :: DirectivesDefinition CONST
nativeDirectives = forall (s :: Stage). Schema s -> DirectivesDefinition s
AST.directiveDefinitions forall (s :: Stage). Schema s
internalSchema

isUpperCase :: Name t -> Bool
isUpperCase :: forall (t :: NAME). Name t -> Bool
isUpperCase = Char -> Bool
isUpper forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Char
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (t :: NAME). NamePacking a => Name t -> a
unpackName

getDirective :: (MonadReader (TypeContext CONST) m, MonadFail m) => FieldName -> m (DirectiveDefinition CONST)
getDirective :: forall (m :: * -> *).
(MonadReader (TypeContext CONST) m, MonadFail m) =>
FieldName -> m (DirectiveDefinition CONST)
getDirective FieldName
directiveName = do
  [DirectiveDefinition CONST]
dirs <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage). TypeContext s -> [DirectiveDefinition s]
directiveDefinitions
  case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\DirectiveDefinition {FieldName
directiveDefinitionName :: forall (s :: Stage). DirectiveDefinition s -> FieldName
directiveDefinitionName :: FieldName
directiveDefinitionName} -> FieldName
directiveDefinitionName forall a. Eq a => a -> a -> Bool
== FieldName
directiveName) [DirectiveDefinition CONST]
dirs of
    Just DirectiveDefinition CONST
dir -> forall (f :: * -> *) a. Applicative f => a -> f a
pure DirectiveDefinition CONST
dir
    Maybe (DirectiveDefinition CONST)
_ -> forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unknown directive" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show FieldName
directiveName) forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldName
directiveName DirectivesDefinition CONST
nativeDirectives

renderDirectiveTypeName :: FieldName -> (Maybe TypeName, TypeName)
renderDirectiveTypeName :: FieldName -> (Maybe TypeName, TypeName)
renderDirectiveTypeName FieldName
"deprecated" = (forall a. Maybe a
Nothing, TypeName
"Deprecated")
renderDirectiveTypeName FieldName
name = (forall a. a -> Maybe a
Just (coerce :: forall a b. Coercible a b => a -> b
coerce FieldName
name), coerce :: forall a b. Coercible a b => a -> b
coerce FieldName
name)

renderArgumentValue ::
  (IsMap FieldName c, MonadFail m) =>
  c (Argument CONST) ->
  ArgumentDefinition s ->
  ReaderT (TypeContext CONST) m (FieldName, TypeValue)
renderArgumentValue :: forall (c :: * -> *) (m :: * -> *) (s :: Stage).
(IsMap FieldName c, MonadFail m) =>
c (Argument CONST)
-> ArgumentDefinition s
-> ReaderT (TypeContext CONST) m (FieldName, TypeValue)
renderArgumentValue c (Argument CONST)
args ArgumentDefinition {FieldDefinition IN s
argument :: forall (s :: Stage). ArgumentDefinition s -> FieldDefinition IN s
argument :: FieldDefinition IN s
..} = do
  let dirName :: FieldName
dirName = forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
AST.fieldName FieldDefinition IN s
argument
  Value CONST
gqlValue <- forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (stage :: Stage). Value stage
AST.Null) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (valid :: Stage). Argument valid -> Value valid
argumentValue) FieldName
dirName c (Argument CONST)
args
  TypeValue
typeValue <- forall (m :: * -> *).
MonadFail m =>
TypeRef -> Value CONST -> CodeGenT m TypeValue
mapWrappedValue (forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
AST.fieldType FieldDefinition IN s
argument) Value CONST
gqlValue
  FieldName
fName <- forall (m :: * -> *). Monad m => FieldName -> CodeGenT m FieldName
getFieldName FieldName
dirName
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName
fName, TypeValue
typeValue)

mapWrappedValue :: MonadFail m => TypeRef -> AST.Value CONST -> CodeGenT m TypeValue
mapWrappedValue :: forall (m :: * -> *).
MonadFail m =>
TypeRef -> Value CONST -> CodeGenT m TypeValue
mapWrappedValue (TypeRef TypeName
name (AST.BaseType Bool
isRequired)) Value CONST
value
  | Bool
isRequired = forall (m :: * -> *).
MonadFail m =>
TypeName -> Value CONST -> CodeGenT m TypeValue
mapValue TypeName
name Value CONST
value
  | Value CONST
value forall a. Eq a => a -> a -> Bool
== forall (stage :: Stage). Value stage
AST.Null = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TypeValue -> TypeValue
TypedValueMaybe forall a. Maybe a
Nothing)
  | Bool
otherwise = Maybe TypeValue -> TypeValue
TypedValueMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadFail m =>
TypeName -> Value CONST -> CodeGenT m TypeValue
mapValue TypeName
name Value CONST
value
mapWrappedValue (TypeRef TypeName
name (AST.TypeList TypeWrapper
elems Bool
isRequired)) Value CONST
d = case Value CONST
d of
  Value CONST
AST.Null | Bool -> Bool
not Bool
isRequired -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TypeValue -> TypeValue
TypedValueMaybe forall a. Maybe a
Nothing)
  (AST.List [Value CONST]
xs) -> Maybe TypeValue -> TypeValue
TypedValueMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeValue] -> TypeValue
TypeValueList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *).
MonadFail m =>
TypeRef -> Value CONST -> CodeGenT m TypeValue
mapWrappedValue (TypeName -> TypeWrapper -> TypeRef
TypeRef TypeName
name TypeWrapper
elems)) [Value CONST]
xs
  Value CONST
value -> forall (m :: * -> *).
MonadFail m =>
String -> Value CONST -> CodeGenT m TypeValue
expected String
"list" Value CONST
value

mapValue :: MonadFail m => TypeName -> AST.Value CONST -> CodeGenT m TypeValue
mapValue :: forall (m :: * -> *).
MonadFail m =>
TypeName -> Value CONST -> CodeGenT m TypeValue
mapValue TypeName
name (AST.List [Value CONST]
xs) = [TypeValue] -> TypeValue
TypeValueList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *).
MonadFail m =>
TypeName -> Value CONST -> CodeGenT m TypeValue
mapValue TypeName
name) [Value CONST]
xs
mapValue TypeName
_ (AST.Enum TypeName
name) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TypeName -> [(FieldName, TypeValue)] -> TypeValue
TypeValueObject TypeName
name []
mapValue TypeName
name (AST.Object Object CONST
fields) = TypeName -> [(FieldName, TypeValue)] -> TypeValue
TypeValueObject TypeName
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *).
MonadFail m =>
TypeName -> ObjectEntry CONST -> CodeGenT m (FieldName, TypeValue)
mapField TypeName
name) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Object CONST
fields)
mapValue TypeName
_ (AST.Scalar ScalarValue
x) = forall (m :: * -> *).
MonadFail m =>
ScalarValue -> CodeGenT m TypeValue
mapScalarValue ScalarValue
x
mapValue TypeName
t Value CONST
v = forall (m :: * -> *).
MonadFail m =>
String -> Value CONST -> CodeGenT m TypeValue
expected (forall b a. (Show a, IsString b) => a -> b
show TypeName
t) Value CONST
v

mapScalarValue :: MonadFail m => AST.ScalarValue -> CodeGenT m TypeValue
mapScalarValue :: forall (m :: * -> *).
MonadFail m =>
ScalarValue -> CodeGenT m TypeValue
mapScalarValue (AST.Int Int
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Double -> TypeValue
TypeValueNumber (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x)
mapScalarValue (AST.Float Double
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Double -> TypeValue
TypeValueNumber Double
x
mapScalarValue (AST.String Text
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> TypeValue
TypeValueString Text
x
mapScalarValue (AST.Boolean Bool
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool -> TypeValue
TypeValueBool Bool
x
mapScalarValue (AST.Value Value
_) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"JSON objects are not supported!"

expected :: MonadFail m => String -> AST.Value CONST -> CodeGenT m TypeValue
expected :: forall (m :: * -> *).
MonadFail m =>
String -> Value CONST -> CodeGenT m TypeValue
expected String
typ Value CONST
value = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"expected " forall a. Semigroup a => a -> a -> a
<> String
typ forall a. Semigroup a => a -> a -> a
<> String
", found " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show (forall a. RenderGQL a => a -> ByteString
render Value CONST
value) forall a. Semigroup a => a -> a -> a
<> String
"!")

mapField :: MonadFail m => TypeName -> ObjectEntry CONST -> CodeGenT m (FieldName, TypeValue)
mapField :: forall (m :: * -> *).
MonadFail m =>
TypeName -> ObjectEntry CONST -> CodeGenT m (FieldName, TypeValue)
mapField TypeName
tName ObjectEntry {Value CONST
FieldName
entryName :: forall (s :: Stage). ObjectEntry s -> FieldName
entryValue :: forall (s :: Stage). ObjectEntry s -> Value s
entryValue :: Value CONST
entryName :: FieldName
..} = do
  TypeRef
t <- forall (m :: * -> *).
MonadFail m =>
TypeName -> FieldName -> CodeGenT m TypeRef
lookupFieldType TypeName
tName FieldName
entryName
  TypeValue
value <- forall (m :: * -> *).
MonadFail m =>
TypeRef -> Value CONST -> CodeGenT m TypeValue
mapWrappedValue TypeRef
t Value CONST
entryValue
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName
entryName, TypeValue
value)