{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Utils.Types
  ( argumentsToObject,
    nodeToType,
    GQLTypeNode (..),
    DerivingMonad,
    fromSchema,
    withObject,
    typeToArguments,
    CatType (..),
    NodeTypeVariant (..),
    GQLTypeNodeExtension (..),
    coerceInputObject,
    coerceScalar,
    getField,
    handleEither,
    coerceArguments,
    coerceObject,
    toFieldContent,
  )
where

import Control.Monad.Except (MonadError (..), throwError)
import Data.Morpheus.Internal.Ext
  ( GQLResult,
    Result (Failure, Success, errors),
  )
import Data.Morpheus.Internal.Utils (selectOr)
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CatType (..),
  )
import Data.Morpheus.Types.GQLScalar
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    Argument (..),
    Arguments,
    ArgumentsDefinition,
    CONST,
    DirectiveDefinition (..),
    FieldContent (..),
    FieldName,
    FieldsDefinition,
    GQLError,
    IN,
    Msg (..),
    OBJECT,
    OUT,
    ObjectEntry (..),
    Position (..),
    ScalarValue,
    Schema (..),
    TRUE,
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    VALID,
    ValidObject,
    ValidValue,
    Value (..),
    fieldsToArguments,
    internal,
  )
import Language.Haskell.TH (Exp, Q)
import Relude hiding (empty)

type DerivingMonad m = (MonadError GQLError m)

fromSchema :: GQLResult (Schema VALID) -> Q Exp
fromSchema :: GQLResult (Schema VALID) -> Q Exp
fromSchema Success {} = [|()|]
fromSchema Failure {NonEmpty GQLError
errors :: forall err a. Result err a -> NonEmpty err
errors :: NonEmpty GQLError
errors} = String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (NonEmpty GQLError -> String
forall b a. (Show a, IsString b) => a -> b
show NonEmpty GQLError
errors)

withObject :: (DerivingMonad m) => TypeName -> TypeContent TRUE any s -> m (FieldsDefinition OUT s)
withObject :: forall (m :: * -> *) (any :: TypeCategory) (s :: Stage).
DerivingMonad m =>
TypeName -> TypeContent TRUE any s -> m (FieldsDefinition OUT s)
withObject TypeName
_ DataObject {FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields} = FieldsDefinition OUT s -> m (FieldsDefinition OUT s)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldsDefinition OUT s
objectFields
withObject TypeName
name TypeContent TRUE any s
_ = TypeName -> m (FieldsDefinition OUT s)
forall (m :: * -> *) b. DerivingMonad m => TypeName -> m b
failureOnlyObject TypeName
name

failureOnlyObject :: (DerivingMonad m) => TypeName -> m b
failureOnlyObject :: forall (m :: * -> *) b. DerivingMonad m => TypeName -> m b
failureOnlyObject TypeName
name = GQLError -> m b
forall a. GQLError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> m b) -> GQLError -> m b
forall a b. (a -> b) -> a -> b
$ TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg TypeName
name GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" should have only one nonempty constructor"

getField :: FieldName -> ValidObject -> ValidValue
getField :: FieldName -> ValidObject -> ValidValue
getField = ValidValue
-> (ObjectEntry VALID -> ValidValue)
-> FieldName
-> ValidObject
-> ValidValue
forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr ValidValue
forall (stage :: Stage). Value stage
Null ObjectEntry VALID -> ValidValue
forall (s :: Stage). ObjectEntry s -> Value s
entryValue

handleEither :: (MonadError GQLError m, Msg t) => Either t a -> m a
handleEither :: forall (m :: * -> *) t a.
(MonadError GQLError m, Msg t) =>
Either t a -> m a
handleEither = (t -> m a) -> (a -> m a) -> Either t a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (GQLError -> m a
forall a. GQLError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> m a) -> (t -> GQLError) -> t -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> GQLError
forall a. Msg a => a -> GQLError
msg) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

typeToArguments :: (DerivingMonad m) => TypeDefinition IN CONST -> m (ArgumentsDefinition CONST)
typeToArguments :: forall (m :: * -> *).
DerivingMonad m =>
TypeDefinition IN CONST -> m (ArgumentsDefinition CONST)
typeToArguments TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataInputObject {FieldsDefinition IN CONST
inputObjectFields :: FieldsDefinition IN CONST
inputObjectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent INPUT_OBJECT a s -> FieldsDefinition IN s
inputObjectFields}} = ArgumentsDefinition CONST -> m (ArgumentsDefinition CONST)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ArgumentsDefinition CONST -> m (ArgumentsDefinition CONST))
-> ArgumentsDefinition CONST -> m (ArgumentsDefinition CONST)
forall a b. (a -> b) -> a -> b
$ FieldsDefinition IN CONST -> ArgumentsDefinition CONST
forall (s :: Stage). FieldsDefinition IN s -> ArgumentsDefinition s
fieldsToArguments FieldsDefinition IN CONST
inputObjectFields
typeToArguments TypeDefinition {TypeName
typeName :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName} = TypeName -> m (ArgumentsDefinition CONST)
forall (m :: * -> *) b. DerivingMonad m => TypeName -> m b
failureOnlyObject TypeName
typeName

toFieldContent :: CatType c a -> ArgumentsDefinition CONST -> Maybe (FieldContent TRUE c CONST)
toFieldContent :: forall (c :: TypeCategory) a.
CatType c a
-> ArgumentsDefinition CONST -> Maybe (FieldContent TRUE c CONST)
toFieldContent CatType c a
OutputType ArgumentsDefinition CONST
x | Bool -> Bool
not (ArgumentsDefinition CONST -> Bool
forall a. OrdMap FieldName a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ArgumentsDefinition CONST
x) = FieldContent TRUE c CONST -> Maybe (FieldContent TRUE c CONST)
forall a. a -> Maybe a
Just (ArgumentsDefinition CONST -> FieldContent (OUT <=? c) c CONST
forall (s :: Stage) (cat :: TypeCategory).
ArgumentsDefinition s -> FieldContent (OUT <=? cat) cat s
FieldArgs ArgumentsDefinition CONST
x)
toFieldContent CatType c a
_ ArgumentsDefinition CONST
_ = Maybe (FieldContent TRUE c CONST)
forall a. Maybe a
Nothing

-- if value is already validated but value has different type
typeMismatch :: GQLError -> Value s -> GQLError
typeMismatch :: forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch GQLError
text Value s
jsType =
  GQLError -> GQLError
internal (GQLError -> GQLError) -> GQLError -> GQLError
forall a b. (a -> b) -> a -> b
$
    GQLError
"Type mismatch! expected:"
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
text
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
", got: "
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> Value s -> GQLError
forall a. Msg a => a -> GQLError
msg Value s
jsType

coerceInputObject :: (MonadError GQLError m) => ValidValue -> m ValidObject
coerceInputObject :: forall (m :: * -> *).
MonadError GQLError m =>
ValidValue -> m ValidObject
coerceInputObject (Object ValidObject
object) = ValidObject -> m ValidObject
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidObject
object
coerceInputObject ValidValue
isType = GQLError -> m ValidObject
forall a. GQLError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> ValidValue -> GQLError
forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch GQLError
"InputObject" ValidValue
isType)

coerceScalar :: (MonadError GQLError m) => TypeName -> Value VALID -> m ScalarValue
coerceScalar :: forall (m :: * -> *).
MonadError GQLError m =>
TypeName -> ValidValue -> m ScalarValue
coerceScalar TypeName
typename ValidValue
value = case ValidValue -> Either Text ScalarValue
toScalar ValidValue
value of
  Right ScalarValue
scalar -> ScalarValue -> m ScalarValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScalarValue
scalar
  Left Text
message ->
    GQLError -> m ScalarValue
forall a. GQLError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
      ( GQLError -> ValidValue -> GQLError
forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch
          (GQLError
"SCALAR(" GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg TypeName
typename GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
")" GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> Text -> GQLError
forall a. Msg a => a -> GQLError
msg Text
message)
          ValidValue
value
      )

coerceArguments :: (MonadError GQLError m) => Value s -> m (Arguments s)
coerceArguments :: forall (m :: * -> *) (s :: Stage).
MonadError GQLError m =>
Value s -> m (Arguments s)
coerceArguments (Object Object s
v) = Arguments s -> m (Arguments s)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Arguments s -> m (Arguments s)) -> Arguments s -> m (Arguments s)
forall a b. (a -> b) -> a -> b
$ (ObjectEntry s -> Argument s) -> Object s -> Arguments s
forall a b. (a -> b) -> OrdMap FieldName a -> OrdMap FieldName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ObjectEntry {FieldName
Value s
entryValue :: forall (s :: Stage). ObjectEntry s -> Value s
entryName :: FieldName
entryValue :: Value s
entryName :: forall (s :: Stage). ObjectEntry s -> FieldName
..} -> Position -> FieldName -> Value s -> Argument s
forall (valid :: Stage).
Position -> FieldName -> Value valid -> Argument valid
Argument (Int -> Int -> Position
Position Int
0 Int
0) FieldName
entryName Value s
entryValue) Object s
v
coerceArguments Value s
_ = GQLError -> m (Arguments s)
forall a. GQLError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> m (Arguments s)) -> GQLError -> m (Arguments s)
forall a b. (a -> b) -> a -> b
$ GQLError -> GQLError
internal GQLError
"could not encode arguments. Arguments should be an object like type!"

argumentsToObject :: Arguments VALID -> Value VALID
argumentsToObject :: Arguments VALID -> ValidValue
argumentsToObject = ValidObject -> ValidValue
forall (stage :: Stage). Object stage -> Value stage
Object (ValidObject -> ValidValue)
-> (Arguments VALID -> ValidObject)
-> Arguments VALID
-> ValidValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Argument VALID -> ObjectEntry VALID)
-> Arguments VALID -> ValidObject
forall a b. (a -> b) -> OrdMap FieldName a -> OrdMap FieldName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Argument VALID -> ObjectEntry VALID
forall {s :: Stage}. Argument s -> ObjectEntry s
toEntry
  where
    toEntry :: Argument s -> ObjectEntry s
toEntry Argument {Position
FieldName
Value s
argumentPosition :: Position
argumentName :: FieldName
argumentValue :: Value s
argumentPosition :: forall (valid :: Stage). Argument valid -> Position
argumentName :: forall (valid :: Stage). Argument valid -> FieldName
argumentValue :: forall (valid :: Stage). Argument valid -> Value valid
..} = FieldName -> Value s -> ObjectEntry s
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
argumentName Value s
argumentValue

data GQLTypeNodeExtension
  = ImplementsExtension TypeName [TypeName]
  | UnionVariantsExtension [NodeTypeVariant]

data GQLTypeNode c
  = GQLTypeNode (TypeDefinition c CONST) [GQLTypeNodeExtension]
  | GQLDirectiveNode (DirectiveDefinition CONST)

nodeToType :: (DerivingMonad m) => GQLTypeNode c -> m (TypeDefinition c CONST)
nodeToType :: forall (m :: * -> *) (c :: TypeCategory).
DerivingMonad m =>
GQLTypeNode c -> m (TypeDefinition c CONST)
nodeToType GQLTypeNode c
node = case GQLTypeNode c
node of
  GQLTypeNode TypeDefinition c CONST
x [GQLTypeNodeExtension]
_ -> TypeDefinition c CONST -> m (TypeDefinition c CONST)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDefinition c CONST
x
  GQLDirectiveNode DirectiveDefinition CONST
dir -> GQLError -> m (TypeDefinition c CONST)
forall a. GQLError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> m (TypeDefinition c CONST))
-> GQLError -> m (TypeDefinition c CONST)
forall a b. (a -> b) -> a -> b
$ GQLError
"expected " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> FieldName -> GQLError
forall a. Msg a => a -> GQLError
msg (DirectiveDefinition CONST -> FieldName
forall (s :: Stage). DirectiveDefinition s -> FieldName
directiveDefinitionName DirectiveDefinition CONST
dir) GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" to be a type but its directive!"

coerceObject :: (DerivingMonad m) => TypeDefinition c CONST -> m (TypeDefinition OBJECT CONST)
coerceObject :: forall (m :: * -> *) (c :: TypeCategory).
DerivingMonad m =>
TypeDefinition c CONST -> m (TypeDefinition OBJECT CONST)
coerceObject TypeDefinition {Maybe Text
Directives CONST
TypeName
TypeContent TRUE c CONST
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeDescription :: Maybe Text
typeName :: TypeName
typeDirectives :: Directives CONST
typeContent :: TypeContent TRUE c CONST
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Text
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
..} = do
  FieldsDefinition OUT CONST
x <- TypeName
-> TypeContent TRUE c CONST -> m (FieldsDefinition OUT CONST)
forall (m :: * -> *) (any :: TypeCategory) (s :: Stage).
DerivingMonad m =>
TypeName -> TypeContent TRUE any s -> m (FieldsDefinition OUT s)
withObject TypeName
typeName TypeContent TRUE c CONST
typeContent
  TypeDefinition OBJECT CONST -> m (TypeDefinition OBJECT CONST)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition {typeContent :: TypeContent TRUE OBJECT CONST
typeContent = [TypeName]
-> FieldsDefinition OUT CONST
-> TypeContent (OBJECT <=? OBJECT) OBJECT CONST
forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (OBJECT <=? a) a s
DataObject [] FieldsDefinition OUT CONST
x, Maybe Text
Directives CONST
TypeName
typeName :: TypeName
typeDescription :: Maybe Text
typeName :: TypeName
typeDirectives :: Directives CONST
typeDescription :: Maybe Text
typeDirectives :: Directives CONST
..})

data NodeTypeVariant
  = NodeTypeVariant TypeName (TypeContent TRUE ANY CONST)
  | NodeUnitType