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

module Data.Morpheus.CodeGen.Server.Interpreting.Directive
  ( getDirectives,
    getNamespaceDirs,
    getDefaultValueDir,
    getRenameDir,
  )
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
  ( CodeGenM,
    ServerCodeGenContext (..),
    getEnumName,
    getFieldName,
    inType,
    lookupFieldType,
  )
import Data.Morpheus.CodeGen.Utils (langExtension)
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)

withDir :: CodeGenM m => [ServerDirectiveUsage] -> m [ServerDirectiveUsage]
withDir :: forall (m :: * -> *).
CodeGenM m =>
[ServerDirectiveUsage] -> m [ServerDirectiveUsage]
withDir [ServerDirectiveUsage]
xs
  | [ServerDirectiveUsage] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ServerDirectiveUsage]
xs = [ServerDirectiveUsage] -> m [ServerDirectiveUsage]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  | Bool
otherwise = Text -> m ()
forall (m :: * -> *). MonadState Flags m => Text -> m ()
langExtension Text
"OverloadedStrings" m () -> m [ServerDirectiveUsage] -> m [ServerDirectiveUsage]
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [ServerDirectiveUsage] -> m [ServerDirectiveUsage]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ServerDirectiveUsage]
xs

getRenameDir :: CodeGenM m => Name t -> Name t -> m [ServerDirectiveUsage]
getRenameDir :: forall (m :: * -> *) (t :: NAME).
CodeGenM m =>
Name t -> Name t -> m [ServerDirectiveUsage]
getRenameDir Name t
originalTypeName Name t
hsTypeName = [ServerDirectiveUsage] -> m [ServerDirectiveUsage]
forall (m :: * -> *).
CodeGenM m =>
[ServerDirectiveUsage] -> m [ServerDirectiveUsage]
withDir [TypeValue -> ServerDirectiveUsage
TypeDirectiveUsage (Name t -> TypeValue
forall (t :: NAME). Name t -> TypeValue
dirRename Name t
originalTypeName) | Name t
originalTypeName Name t -> Name t -> Bool
forall a. Eq a => a -> a -> Bool
/= Name t
hsTypeName]

getDirectives :: (CodeGenM m, Meta a) => a -> m [ServerDirectiveUsage]
getDirectives :: forall (m :: * -> *) a.
(CodeGenM m, Meta a) =>
a -> m [ServerDirectiveUsage]
getDirectives = a -> m [ServerDirectiveUsage]
forall a (m :: * -> *).
(Meta a, CodeGenM m) =>
a -> m [ServerDirectiveUsage]
forall (m :: * -> *). CodeGenM m => a -> m [ServerDirectiveUsage]
getDirs (a -> m [ServerDirectiveUsage])
-> ([ServerDirectiveUsage] -> m [ServerDirectiveUsage])
-> a
-> m [ServerDirectiveUsage]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [ServerDirectiveUsage] -> m [ServerDirectiveUsage]
forall (m :: * -> *).
CodeGenM m =>
[ServerDirectiveUsage] -> m [ServerDirectiveUsage]
withDir

getDefaultValueDir :: (CodeGenM m) => FieldDefinition c CONST -> m [ServerDirectiveUsage]
getDefaultValueDir :: forall (m :: * -> *) (c :: TypeCategory).
CodeGenM m =>
FieldDefinition c CONST -> m [ServerDirectiveUsage]
getDefaultValueDir
  FieldDefinition
    { FieldName
fieldName :: FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName,
      fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent = Just DefaultInputValue {Value CONST
defaultInputValue :: Value CONST
defaultInputValue :: forall (s :: Stage) (cat :: TypeCategory).
FieldContent (IN <=? cat) cat s -> Value s
defaultInputValue}
    } = do
    FieldName
name <- FieldName -> m FieldName
forall (m :: * -> *). CodeGenM m => FieldName -> m FieldName
getFieldName FieldName
fieldName
    [ServerDirectiveUsage] -> m [ServerDirectiveUsage]
forall (m :: * -> *).
CodeGenM m =>
[ServerDirectiveUsage] -> m [ServerDirectiveUsage]
withDir [FieldName -> TypeValue -> ServerDirectiveUsage
FieldDirectiveUsage FieldName
name (Value CONST -> TypeValue
defValDirective Value CONST
defaultInputValue)]
getDefaultValueDir FieldDefinition c CONST
_ = [ServerDirectiveUsage] -> m [ServerDirectiveUsage]
forall a. a -> m a
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 (PrintableValue -> TypeValue) -> PrintableValue -> TypeValue
forall a b. (a -> b) -> a -> b
$ Value CONST -> PrintableValue
forall a. (Show a, Lift a) => a -> PrintableValue
PrintableValue Value CONST
desc)]

getNamespaceDirs :: CodeGenM m => Text -> m [ServerDirectiveUsage]
getNamespaceDirs :: forall (m :: * -> *).
CodeGenM m =>
Text -> m [ServerDirectiveUsage]
getNamespaceDirs Text
genTypeName = do
  Bool
namespaces <- (ServerCodeGenContext -> Bool) -> m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServerCodeGenContext -> Bool
hasNamespace
  [ServerDirectiveUsage] -> m [ServerDirectiveUsage]
forall (m :: * -> *).
CodeGenM m =>
[ServerDirectiveUsage] -> m [ServerDirectiveUsage]
withDir [TypeValue -> ServerDirectiveUsage
TypeDirectiveUsage (Text -> TypeValue
dirDropNamespace Text
genTypeName) | Bool
namespaces]

descDirective :: Maybe Description -> [TypeValue]
descDirective :: Maybe Text -> [TypeValue]
descDirective Maybe Text
desc = (Text -> TypeValue) -> [Text] -> [TypeValue]
forall a b. (a -> b) -> [a] -> [b]
map Text -> TypeValue
describe (Maybe Text -> [Text]
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 (Name t -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
unpackName Name t
name))]

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

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

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

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

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

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

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

directiveTypeValue :: CodeGenM m => Directive CONST -> m TypeValue
directiveTypeValue :: forall (m :: * -> *). CodeGenM m => Directive CONST -> m TypeValue
directiveTypeValue Directive {Arguments CONST
Position
FieldName
directiveArgs :: forall (s :: Stage). Directive s -> Arguments s
directiveName :: forall (s :: Stage). Directive s -> FieldName
directivePosition :: Position
directiveName :: FieldName
directiveArgs :: Arguments CONST
directivePosition :: forall (s :: Stage). Directive s -> Position
..} = Maybe TypeName -> m TypeValue -> m TypeValue
forall (m :: * -> *) a.
MonadReader ServerCodeGenContext m =>
Maybe TypeName -> m a -> m a
inType Maybe TypeName
typeContext (m TypeValue -> m TypeValue) -> m TypeValue -> m TypeValue
forall a b. (a -> b) -> a -> b
$ do
  DirectiveDefinition CONST
dirs <- FieldName -> m (DirectiveDefinition CONST)
forall (m :: * -> *).
CodeGenM m =>
FieldName -> m (DirectiveDefinition CONST)
getDirective FieldName
directiveName
  TypeName -> [(FieldName, TypeValue)] -> TypeValue
TypeValueObject TypeName
typename ([(FieldName, TypeValue)] -> TypeValue)
-> m [(FieldName, TypeValue)] -> m TypeValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ArgumentDefinition CONST -> m (FieldName, TypeValue))
-> [ArgumentDefinition CONST] -> m [(FieldName, TypeValue)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Arguments CONST
-> ArgumentDefinition CONST -> m (FieldName, TypeValue)
forall (c :: * -> *) (m :: * -> *) (s :: Stage).
(IsMap FieldName c, CodeGenM m) =>
c (Argument CONST)
-> ArgumentDefinition s -> m (FieldName, TypeValue)
renderArgumentValue Arguments CONST
directiveArgs) (OrdMap FieldName (ArgumentDefinition CONST)
-> [ArgumentDefinition CONST]
forall a. OrdMap FieldName a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (OrdMap FieldName (ArgumentDefinition CONST)
 -> [ArgumentDefinition CONST])
-> OrdMap FieldName (ArgumentDefinition CONST)
-> [ArgumentDefinition CONST]
forall a b. (a -> b) -> a -> b
$ DirectiveDefinition CONST
-> OrdMap FieldName (ArgumentDefinition CONST)
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 = Schema CONST -> DirectivesDefinition CONST
forall (s :: Stage). Schema s -> DirectivesDefinition s
AST.directiveDefinitions Schema CONST
forall (s :: Stage). Schema s
internalSchema

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

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

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

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

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

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

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

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