{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Internal.TH.Decode
  ( withInputObject,
    withEnum,
    withInputUnion,
    decodeFieldWith,
    withScalar,
    handleEither,
  )
where

import Data.Morpheus.App.Internal.Resolving
  ( Failure (..),
  )
import Data.Morpheus.Internal.Utils
  ( selectOr,
  )
import Data.Morpheus.Types.GQLScalar
  ( toScalar,
  )
import Data.Morpheus.Types.Internal.AST
  ( FieldName,
    InternalError,
    Message,
    ObjectEntry (..),
    ScalarValue,
    Token,
    TypeName (..),
    VALID,
    ValidObject,
    ValidValue,
    Value (..),
    getInputUnionValue,
    msg,
    msgInternal,
  )
import Relude hiding (empty)

withInputObject ::
  Failure InternalError m =>
  (ValidObject -> m a) ->
  ValidValue ->
  m a
withInputObject :: (ValidObject -> m a) -> ValidValue -> m a
withInputObject ValidObject -> m a
f (Object ValidObject
object) = ValidObject -> m a
f ValidObject
object
withInputObject ValidObject -> m a
_ ValidValue
isType = InternalError -> m a
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (Message -> ValidValue -> InternalError
forall (s :: Stage). Message -> Value s -> InternalError
typeMismatch Message
"InputObject" ValidValue
isType)

-- | Useful for more restrictive instances of lists (non empty, size indexed etc)
withEnum :: Failure InternalError m => (TypeName -> m a) -> Value VALID -> m a
withEnum :: (TypeName -> m a) -> ValidValue -> m a
withEnum TypeName -> m a
decode (Enum TypeName
value) = TypeName -> m a
decode TypeName
value
withEnum TypeName -> m a
_ ValidValue
isType = InternalError -> m a
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (Message -> ValidValue -> InternalError
forall (s :: Stage). Message -> Value s -> InternalError
typeMismatch Message
"Enum" ValidValue
isType)

withInputUnion ::
  (Failure InternalError m, Monad m) =>
  (TypeName -> ValidObject -> ValidObject -> m a) ->
  ValidObject ->
  m a
withInputUnion :: (TypeName -> ValidObject -> ValidObject -> m a)
-> ValidObject -> m a
withInputUnion TypeName -> ValidObject -> ValidObject -> m a
decoder ValidObject
unions =
  (Message -> m a)
-> ((TypeName, ValidValue) -> m a)
-> Either Message (TypeName, ValidValue)
-> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Message -> m a
forall v. Message -> m v
onFail (TypeName, ValidValue) -> m a
onSucc (ValidObject -> Either Message (TypeName, ValidValue)
forall (stage :: Stage).
Object stage -> Either Message (TypeName, Value stage)
getInputUnionValue ValidObject
unions)
  where
    onSucc :: (TypeName, ValidValue) -> m a
onSucc (TypeName
name, ValidValue
value) = (ValidObject -> m a) -> ValidValue -> m a
forall (m :: * -> *) a.
Failure InternalError m =>
(ValidObject -> m a) -> ValidValue -> m a
withInputObject (TypeName -> ValidObject -> ValidObject -> m a
decoder TypeName
name ValidObject
unions) ValidValue
value
    onFail :: Message -> m v
onFail = InternalError -> m v
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (InternalError -> m v)
-> (Message -> InternalError) -> Message -> m v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> InternalError
forall a. Msg a => a -> InternalError
msgInternal

withScalar ::
  (Applicative m, Failure InternalError m) =>
  TypeName ->
  (ScalarValue -> Either Token a) ->
  Value VALID ->
  m a
withScalar :: TypeName -> (ScalarValue -> Either Token a) -> ValidValue -> m a
withScalar TypeName
typename ScalarValue -> Either Token a
decodeScalar ValidValue
value = case ValidValue -> Either Token ScalarValue
toScalar ValidValue
value Either Token ScalarValue
-> (ScalarValue -> Either Token a) -> Either Token a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ScalarValue -> Either Token a
decodeScalar of
  Right a
scalar -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
scalar
  Left Token
message ->
    InternalError -> m a
forall error (f :: * -> *) v. Failure error f => error -> f v
failure
      ( Message -> ValidValue -> InternalError
forall (s :: Stage). Message -> Value s -> InternalError
typeMismatch
          (Message
"SCALAR(" Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> TypeName -> Message
forall a. Msg a => a -> Message
msg TypeName
typename Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
")" Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Token -> Message
forall a. Msg a => a -> Message
msg Token
message)
          ValidValue
value
      )

decodeFieldWith :: (Value VALID -> m a) -> FieldName -> ValidObject -> m a
decodeFieldWith :: (ValidValue -> m a) -> FieldName -> ValidObject -> m a
decodeFieldWith ValidValue -> m a
decoder = m a
-> (ObjectEntry VALID -> m a) -> FieldName -> ValidObject -> m a
forall k a c d. Selectable k a c => d -> (a -> d) -> k -> c -> d
selectOr (ValidValue -> m a
decoder ValidValue
forall (stage :: Stage). Value stage
Null) (ValidValue -> m a
decoder (ValidValue -> m a)
-> (ObjectEntry VALID -> ValidValue) -> ObjectEntry VALID -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectEntry VALID -> ValidValue
forall (s :: Stage). ObjectEntry s -> Value s
entryValue)

handleEither :: Failure InternalError m => Either Message a -> m a
handleEither :: Either Message a -> m a
handleEither = (Message -> m a) -> (a -> m a) -> Either Message a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (InternalError -> m a
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (InternalError -> m a)
-> (Message -> InternalError) -> Message -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> InternalError
forall a. Msg a => a -> InternalError
msgInternal) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- if value is already validated but value has different type
typeMismatch :: Message -> Value s -> InternalError
typeMismatch :: Message -> Value s -> InternalError
typeMismatch Message
text Value s
jsType =
  InternalError
"Type mismatch! expected:" InternalError -> InternalError -> InternalError
forall a. Semigroup a => a -> a -> a
<> Message -> InternalError
forall a. Msg a => a -> InternalError
msgInternal Message
text InternalError -> InternalError -> InternalError
forall a. Semigroup a => a -> a -> a
<> InternalError
", got: "
    InternalError -> InternalError -> InternalError
forall a. Semigroup a => a -> a -> a
<> Value s -> InternalError
forall a. Msg a => a -> InternalError
msgInternal Value s
jsType