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

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

import Data.Char (isUpper)
import Data.Morpheus.CodeGen.Internal.AST
  ( PrintableValue (..),
    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 (..),
    FieldContent (..),
    FieldDefinition (..),
    FieldName,
    FieldsDefinition,
    Name,
    ObjectEntry (..),
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    TypeRef (..),
    Value,
  )
import qualified Data.Morpheus.Types.Internal.AST as AST
import Data.Text (head)
import Relude hiding (ByteString, get, head)

getDefaultValueDir :: (Monad m) => FieldDefinition c CONST -> CodeGenT m [ServerDirectiveUsage]
getDefaultValueDir :: forall (m :: * -> *) (c :: TypeCategory).
Monad m =>
FieldDefinition c CONST -> CodeGenT m [ServerDirectiveUsage]
getDefaultValueDir
  FieldDefinition
    { FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName,
      fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent = Just DefaultInputValue {Value CONST
defaultInputValue :: forall (s :: Stage) (cat :: TypeCategory).
FieldContent (IN <=? cat) cat s -> Value s
defaultInputValue :: Value CONST
defaultInputValue}
    } = do
    FieldName
name <- forall (m :: * -> *). Monad m => FieldName -> CodeGenT m FieldName
getFieldName FieldName
fieldName
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [FieldName -> TypeValue -> ServerDirectiveUsage
FieldDirectiveUsage FieldName
name (Value CONST -> TypeValue
defValDirective Value CONST
defaultInputValue)]
getDefaultValueDir FieldDefinition c CONST
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []

defValDirective :: Value CONST -> TypeValue
defValDirective :: Value CONST -> TypeValue
defValDirective Value CONST
desc = TypeName -> [(FieldName, TypeValue)] -> TypeValue
TypeValueObject TypeName
"DefaultValue" [(FieldName
"defaultValue", PrintableValue -> TypeValue
PrintableTypeValue forall a b. (a -> b) -> a -> b
$ forall a. (Show a, Lift a) => a -> PrintableValue
PrintableValue Value CONST
desc)]

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 :: FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> 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)