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

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

-- MORPHEUS

import Control.Applicative (Applicative (..))
import Control.Monad (Monad ((>>=)))
import Data.Either (Either (..))
import Data.Functor ((<$>))
import Data.Maybe (Maybe (..))
import Data.Morpheus.Internal.Utils
  ( empty,
    selectBy,
    selectOr,
  )
import Data.Morpheus.Types.GQLScalar
  ( toScalar,
  )
import Data.Morpheus.Types.Internal.AST
  ( FieldName,
    InternalError,
    Message,
    ObjectEntry (..),
    ScalarValue,
    Token,
    TypeName (..),
    VALID,
    ValidObject,
    ValidValue,
    Value (..),
    msg,
    msgInternal,
    toFieldName,
  )
import Data.Morpheus.Types.Internal.Resolving
  ( Failure (..),
  )
import Data.Semigroup ((<>))
import Data.Traversable (traverse)
import Prelude ((.))

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
"Object" ValidValue
isType)

withMaybe :: Monad m => (ValidValue -> m a) -> ValidValue -> m (Maybe a)
withMaybe :: (ValidValue -> m a) -> ValidValue -> m (Maybe a)
withMaybe ValidValue -> m a
_ ValidValue
Null = Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
withMaybe ValidValue -> m a
decode ValidValue
x = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> m a -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValidValue -> m a
decode ValidValue
x

withList ::
  (Failure InternalError m, Monad m) =>
  (ValidValue -> m a) ->
  ValidValue ->
  m [a]
withList :: (ValidValue -> m a) -> ValidValue -> m [a]
withList ValidValue -> m a
decode (List [ValidValue]
li) = (ValidValue -> m a) -> [ValidValue] -> m [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ValidValue -> m a
decode [ValidValue]
li
withList ValidValue -> 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
"List" ValidValue
isType)

-- | Useful for more restrictive instances of lists (non empty, size indexed etc)
withRefinedList ::
  (Failure InternalError m, Monad m) =>
  ([a] -> Either Message (rList a)) ->
  (ValidValue -> m a) ->
  ValidValue ->
  m (rList a)
withRefinedList :: ([a] -> Either Message (rList a))
-> (ValidValue -> m a) -> ValidValue -> m (rList a)
withRefinedList [a] -> Either Message (rList a)
refiner ValidValue -> m a
decode (List [ValidValue]
li) = do
  [a]
listRes <- (ValidValue -> m a) -> [ValidValue] -> m [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ValidValue -> m a
decode [ValidValue]
li
  case [a] -> Either Message (rList a)
refiner [a]
listRes of
    Left Message
err -> InternalError -> m (rList a)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (Message -> ValidValue -> InternalError
forall (s :: Stage). Message -> Value s -> InternalError
typeMismatch Message
err ([ValidValue] -> ValidValue
forall (stage :: Stage). [Value stage] -> Value stage
List [ValidValue]
li))
    Right rList a
value -> rList a -> m (rList a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure rList a
value
withRefinedList [a] -> Either Message (rList a)
_ ValidValue -> m a
_ ValidValue
isType = InternalError -> m (rList a)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (Message -> ValidValue -> InternalError
forall (s :: Stage). Message -> Value s -> InternalError
typeMismatch Message
"List" ValidValue
isType)

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 =
  InternalError -> FieldName -> ValidObject -> m (ObjectEntry VALID)
forall e (m :: * -> *) k a c.
(Failure e m, Selectable k a c, Monad m) =>
e -> k -> c -> m a
selectBy
    (InternalError
"__typename not found on Input Union" :: InternalError)
    (FieldName
"__typename" :: FieldName)
    ValidObject
unions
    m (ObjectEntry VALID) -> (ObjectEntry VALID -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ValidValue -> m a
forall (stage :: Stage). Value stage -> m a
providesValueFor (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
  where
    providesValueFor :: Value stage -> m a
providesValueFor (Enum TypeName
key) = 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 m a
notFound ObjectEntry VALID -> m a
onFound (TypeName -> FieldName
toFieldName TypeName
key) ValidObject
unions
      where
        notFound :: m a
notFound = (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
key ValidObject
unions) (ValidObject -> ValidValue
forall (stage :: Stage). Object stage -> Value stage
Object ValidObject
forall a coll. Collection a coll => coll
empty)
        onFound :: ObjectEntry VALID -> m a
onFound = (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
key ValidObject
unions) (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
    providesValueFor Value stage
_ = InternalError -> m a
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (InternalError
"__typename must be Enum" :: InternalError)

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
parseValue 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
parseValue 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)

-- 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