{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Decode
  ( decodeArguments,
    Decode (..),
    DecodeConstraint,
  )
where

import Control.Applicative (pure, (<*>))
import Control.Monad ((>>=))
import Data.Functor (Functor (..), (<$>))
import Data.List (elem)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (Maybe (..))
import Data.Morpheus.Internal.Utils
  ( elems,
  )
import Data.Morpheus.Kind
  ( ENUM,
    GQL_KIND,
    INPUT,
    OUTPUT,
    SCALAR,
  )
import Data.Morpheus.Server.Deriving.Utils
  ( conNameProxy,
    datatypeNameProxy,
    selNameProxy,
  )
import Data.Morpheus.Server.Internal.TH.Decode (decodeFieldWith, withInputObject, withInputUnion, withList, withMaybe, withRefinedList, withScalar)
import Data.Morpheus.Server.Types.GQLType
  ( GQLType
      ( KIND,
        typeOptions,
        __type
      ),
    GQLTypeOptions (..),
    TypeData (..),
  )
import Data.Morpheus.Types.GQLScalar
  ( GQLScalar (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( Argument (..),
    Arguments,
    InternalError,
    ObjectEntry (..),
    TypeName (..),
    VALID,
    ValidObject,
    ValidValue,
    Value (..),
    msg,
  )
import Data.Morpheus.Types.Internal.Resolving
  ( Failure (..),
    ResolverState,
  )
import Data.Proxy (Proxy (..))
import Data.Semigroup (Semigroup (..))
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String (IsString (fromString))
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import GHC.Generics
import Prelude (Either (Left, Right), Eq (..), Foldable (length), Ord, maybe, otherwise, show, ($), (-), (.))

type DecodeConstraint a =
  ( Generic a,
    GQLType a,
    DecodeRep (Rep a)
  )

-- GENERIC
decodeArguments :: DecodeConstraint a => Arguments VALID -> ResolverState a
decodeArguments :: Arguments VALID -> ResolverState a
decodeArguments = ValidValue -> ResolverState a
forall a. DecodeConstraint a => ValidValue -> ResolverState a
decodeType (ValidValue -> ResolverState a)
-> (Arguments VALID -> ValidValue)
-> Arguments VALID
-> ResolverState a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object VALID -> ValidValue
forall (stage :: Stage). Object stage -> Value stage
Object (Object VALID -> ValidValue)
-> (Arguments VALID -> Object VALID)
-> Arguments VALID
-> ValidValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Argument VALID -> ObjectEntry VALID)
-> Arguments VALID -> Object VALID
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 {Value s
FieldName
Position
argumentPosition :: forall (valid :: Stage). Argument valid -> Position
argumentName :: forall (valid :: Stage). Argument valid -> FieldName
argumentValue :: forall (valid :: Stage). Argument valid -> Value valid
argumentValue :: Value s
argumentName :: FieldName
argumentPosition :: Position
..} = FieldName -> Value s -> ObjectEntry s
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
argumentName Value s
argumentValue

-- | Decode GraphQL query arguments and input values
class Decode a where
  decode :: ValidValue -> ResolverState a

instance {-# OVERLAPPABLE #-} DecodeKind (KIND a) a => Decode a where
  decode :: ValidValue -> ResolverState a
decode = Proxy (KIND a) -> ValidValue -> ResolverState a
forall (kind :: GQL_KIND) a.
DecodeKind kind a =>
Proxy kind -> ValidValue -> ResolverState a
decodeKind (Proxy (KIND a)
forall k (t :: k). Proxy t
Proxy @(KIND a))

instance Decode a => Decode (Maybe a) where
  decode :: ValidValue -> ResolverState (Maybe a)
decode = (ValidValue -> ResolverStateT () Identity a)
-> ValidValue -> ResolverState (Maybe a)
forall (m :: * -> *) a.
Monad m =>
(ValidValue -> m a) -> ValidValue -> m (Maybe a)
withMaybe ValidValue -> ResolverStateT () Identity a
forall a. Decode a => ValidValue -> ResolverState a
decode

instance Decode a => Decode [a] where
  decode :: ValidValue -> ResolverState [a]
decode = (ValidValue -> ResolverStateT () Identity a)
-> ValidValue -> ResolverState [a]
forall (m :: * -> *) a.
(Failure InternalError m, Monad m) =>
(ValidValue -> m a) -> ValidValue -> m [a]
withList ValidValue -> ResolverStateT () Identity a
forall a. Decode a => ValidValue -> ResolverState a
decode

instance Decode a => Decode (NonEmpty a) where
  decode :: ValidValue -> ResolverState (NonEmpty a)
decode = ([a] -> Either Message (NonEmpty a))
-> (ValidValue -> ResolverStateT () Identity a)
-> ValidValue
-> ResolverState (NonEmpty a)
forall (m :: * -> *) a (rList :: * -> *).
(Failure InternalError m, Monad m) =>
([a] -> Either Message (rList a))
-> (ValidValue -> m a) -> ValidValue -> m (rList a)
withRefinedList (Either Message (NonEmpty a)
-> (NonEmpty a -> Either Message (NonEmpty a))
-> Maybe (NonEmpty a)
-> Either Message (NonEmpty a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Message -> Either Message (NonEmpty a)
forall a b. a -> Either a b
Left Message
"Expected a NonEmpty list") NonEmpty a -> Either Message (NonEmpty a)
forall a b. b -> Either a b
Right (Maybe (NonEmpty a) -> Either Message (NonEmpty a))
-> ([a] -> Maybe (NonEmpty a))
-> [a]
-> Either Message (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty) ValidValue -> ResolverStateT () Identity a
forall a. Decode a => ValidValue -> ResolverState a
decode

-- | Should this instance dedupe silently or fail on dupes ?
instance (Ord a, Decode a) => Decode (Set a) where
  decode :: ValidValue -> ResolverState (Set a)
decode ValidValue
val = do
    [a]
listVal <- (ValidValue -> ResolverStateT () Identity a)
-> ValidValue -> ResolverStateT () Identity [a]
forall (m :: * -> *) a.
(Failure InternalError m, Monad m) =>
(ValidValue -> m a) -> ValidValue -> m [a]
withList (Decode a => ValidValue -> ResolverStateT () Identity a
forall a. Decode a => ValidValue -> ResolverState a
decode @a) ValidValue
val
    let setVal :: Set a
setVal = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
listVal
    let setLength :: Int
setLength = Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set a
setVal
    let listLength :: Int
listLength = Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set a
setVal
    if Int
listLength Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
setLength
      then Set a -> ResolverState (Set a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set a
setVal
      else InternalError -> ResolverState (Set a)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (String -> InternalError
forall a. IsString a => String -> a
fromString (String
"Expected a List without duplicates, found " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Int
setLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
listLength) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" duplicates") :: InternalError)

instance (Decode a) => Decode (Seq a) where
  decode :: ValidValue -> ResolverState (Seq a)
decode = ([a] -> Seq a)
-> ResolverStateT () Identity [a] -> ResolverState (Seq a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList (ResolverStateT () Identity [a] -> ResolverState (Seq a))
-> (ValidValue -> ResolverStateT () Identity [a])
-> ValidValue
-> ResolverState (Seq a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidValue -> ResolverStateT () Identity a)
-> ValidValue -> ResolverStateT () Identity [a]
forall (m :: * -> *) a.
(Failure InternalError m, Monad m) =>
(ValidValue -> m a) -> ValidValue -> m [a]
withList ValidValue -> ResolverStateT () Identity a
forall a. Decode a => ValidValue -> ResolverState a
decode

instance (Decode a) => Decode (Vector a) where
  decode :: ValidValue -> ResolverState (Vector a)
decode = ([a] -> Vector a)
-> ResolverStateT () Identity [a] -> ResolverState (Vector a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> Vector a
forall a. [a] -> Vector a
Vector.fromList (ResolverStateT () Identity [a] -> ResolverState (Vector a))
-> (ValidValue -> ResolverStateT () Identity [a])
-> ValidValue
-> ResolverState (Vector a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidValue -> ResolverStateT () Identity a)
-> ValidValue -> ResolverStateT () Identity [a]
forall (m :: * -> *) a.
(Failure InternalError m, Monad m) =>
(ValidValue -> m a) -> ValidValue -> m [a]
withList ValidValue -> ResolverStateT () Identity a
forall a. Decode a => ValidValue -> ResolverState a
decode

-- | Decode GraphQL type with Specific Kind
class DecodeKind (kind :: GQL_KIND) a where
  decodeKind :: Proxy kind -> ValidValue -> ResolverState a

-- SCALAR
instance (GQLScalar a, GQLType a) => DecodeKind SCALAR a where
  decodeKind :: Proxy SCALAR -> ValidValue -> ResolverState a
decodeKind Proxy SCALAR
_ = TypeName
-> (ScalarValue -> Either Token a) -> ValidValue -> ResolverState a
forall (m :: * -> *) a.
(Applicative m, Failure InternalError m) =>
TypeName -> (ScalarValue -> Either Token a) -> ValidValue -> m a
withScalar (TypeData -> TypeName
gqlTypeName (TypeData -> TypeName) -> TypeData -> TypeName
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeData
forall a (f :: * -> *). GQLType a => f a -> TypeData
__type (Proxy a
forall k (t :: k). Proxy t
Proxy @a)) ScalarValue -> Either Token a
forall a. GQLScalar a => ScalarValue -> Either Token a
parseValue

-- ENUM
instance DecodeConstraint a => DecodeKind ENUM a where
  decodeKind :: Proxy ENUM -> ValidValue -> ResolverState a
decodeKind Proxy ENUM
_ = ValidValue -> ResolverState a
forall a. DecodeConstraint a => ValidValue -> ResolverState a
decodeType

-- TODO: remove
instance DecodeConstraint a => DecodeKind OUTPUT a where
  decodeKind :: Proxy OUTPUT -> ValidValue -> ResolverState a
decodeKind Proxy OUTPUT
_ = ValidValue -> ResolverState a
forall a. DecodeConstraint a => ValidValue -> ResolverState a
decodeType

-- INPUT_OBJECT and  INPUT_UNION
instance DecodeConstraint a => DecodeKind INPUT a where
  decodeKind :: Proxy INPUT -> ValidValue -> ResolverState a
decodeKind Proxy INPUT
_ = ValidValue -> ResolverState a
forall a. DecodeConstraint a => ValidValue -> ResolverState a
decodeType

decodeType :: forall a. DecodeConstraint a => ValidValue -> ResolverState a
decodeType :: ValidValue -> ResolverState a
decodeType = (Rep a Any -> a)
-> ResolverStateT () Identity (Rep a Any) -> ResolverState a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (ResolverStateT () Identity (Rep a Any) -> ResolverState a)
-> (ValidValue -> ResolverStateT () Identity (Rep a Any))
-> ValidValue
-> ResolverState a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GQLTypeOptions, ValidValue, Cont)
-> ResolverStateT () Identity (Rep a Any)
forall (f :: * -> *) a.
DecodeRep f =>
(GQLTypeOptions, ValidValue, Cont) -> ResolverState (f a)
decodeRep ((GQLTypeOptions, ValidValue, Cont)
 -> ResolverStateT () Identity (Rep a Any))
-> (ValidValue -> (GQLTypeOptions, ValidValue, Cont))
-> ValidValue
-> ResolverStateT () Identity (Rep a Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Proxy a -> GQLTypeOptions
forall a (f :: * -> *). GQLType a => f a -> GQLTypeOptions
typeOptions (Proxy a
forall k (t :: k). Proxy t
Proxy @a),,Tag -> TypeName -> Cont
Cont Tag
D_CONS TypeName
"")

-- data Input  =
--    InputHuman Human  -- direct link: { __typename: Human, Human: {field: ""} }
--   | InputRecord { name :: Text, age :: Int } -- { __typename: InputRecord, InputRecord: {field: ""} }
--   | IndexedType Int Text  -- { __typename: InputRecord, _0:2 , _1:""  }
--   | Zeus                 -- { __typename: Zeus }
--     deriving (Generic, GQLType)

decideUnion ::
  ([TypeName], value -> ResolverState (f1 a)) ->
  ([TypeName], value -> ResolverState (f2 a)) ->
  TypeName ->
  value ->
  ResolverState ((:+:) f1 f2 a)
decideUnion :: ([TypeName], value -> ResolverState (f1 a))
-> ([TypeName], value -> ResolverState (f2 a))
-> TypeName
-> value
-> ResolverState ((:+:) f1 f2 a)
decideUnion ([TypeName]
left, value -> ResolverState (f1 a)
f1) ([TypeName]
right, value -> ResolverState (f2 a)
f2) TypeName
name value
value
  | TypeName
name TypeName -> [TypeName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TypeName]
left =
    f1 a -> (:+:) f1 f2 a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f1 a -> (:+:) f1 f2 a)
-> ResolverState (f1 a) -> ResolverState ((:+:) f1 f2 a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> value -> ResolverState (f1 a)
f1 value
value
  | TypeName
name TypeName -> [TypeName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TypeName]
right =
    f2 a -> (:+:) f1 f2 a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (f2 a -> (:+:) f1 f2 a)
-> ResolverState (f2 a) -> ResolverState ((:+:) f1 f2 a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> value -> ResolverState (f2 a)
f2 value
value
  | Bool
otherwise =
    Message -> ResolverState ((:+:) f1 f2 a)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (Message -> ResolverState ((:+:) f1 f2 a))
-> Message -> ResolverState ((:+:) f1 f2 a)
forall a b. (a -> b) -> a -> b
$
      Message
"Constructor \""
        Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> TypeName -> Message
forall a. Msg a => a -> Message
msg TypeName
name
        Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
"\" could not find in Union"

data Tag = D_CONS | D_UNION deriving (Tag -> Tag -> Bool
(Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> Eq Tag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tag -> Tag -> Bool
$c/= :: Tag -> Tag -> Bool
== :: Tag -> Tag -> Bool
$c== :: Tag -> Tag -> Bool
Eq, Eq Tag
Eq Tag
-> (Tag -> Tag -> Ordering)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Tag)
-> (Tag -> Tag -> Tag)
-> Ord Tag
Tag -> Tag -> Bool
Tag -> Tag -> Ordering
Tag -> Tag -> Tag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Tag -> Tag -> Tag
$cmin :: Tag -> Tag -> Tag
max :: Tag -> Tag -> Tag
$cmax :: Tag -> Tag -> Tag
>= :: Tag -> Tag -> Bool
$c>= :: Tag -> Tag -> Bool
> :: Tag -> Tag -> Bool
$c> :: Tag -> Tag -> Bool
<= :: Tag -> Tag -> Bool
$c<= :: Tag -> Tag -> Bool
< :: Tag -> Tag -> Bool
$c< :: Tag -> Tag -> Bool
compare :: Tag -> Tag -> Ordering
$ccompare :: Tag -> Tag -> Ordering
$cp1Ord :: Eq Tag
Ord)

data Cont = Cont
  { Cont -> Tag
contKind :: Tag,
    Cont -> TypeName
typeName :: TypeName
  }

data Info = Info
  { Info -> Tag
kind :: Tag,
    Info -> [TypeName]
tagName :: [TypeName]
  }

instance Semigroup Info where
  Info Tag
D_UNION [TypeName]
t1 <> :: Info -> Info -> Info
<> Info Tag
_ [TypeName]
t2 = Tag -> [TypeName] -> Info
Info Tag
D_UNION ([TypeName]
t1 [TypeName] -> [TypeName] -> [TypeName]
forall a. Semigroup a => a -> a -> a
<> [TypeName]
t2)
  Info Tag
_ [TypeName]
t1 <> Info Tag
D_UNION [TypeName]
t2 = Tag -> [TypeName] -> Info
Info Tag
D_UNION ([TypeName]
t1 [TypeName] -> [TypeName] -> [TypeName]
forall a. Semigroup a => a -> a -> a
<> [TypeName]
t2)
  Info Tag
D_CONS [TypeName]
t1 <> Info Tag
D_CONS [TypeName]
t2 = Tag -> [TypeName] -> Info
Info Tag
D_CONS ([TypeName]
t1 [TypeName] -> [TypeName] -> [TypeName]
forall a. Semigroup a => a -> a -> a
<> [TypeName]
t2)

--
-- GENERICS
--
class DecodeRep f where
  tags :: Proxy f -> (GQLTypeOptions, TypeName) -> Info
  decodeRep :: (GQLTypeOptions, ValidValue, Cont) -> ResolverState (f a)

instance (Datatype d, DecodeRep f) => DecodeRep (M1 D d f) where
  tags :: Proxy (M1 D d f) -> (GQLTypeOptions, TypeName) -> Info
tags Proxy (M1 D d f)
_ = Proxy f -> (GQLTypeOptions, TypeName) -> Info
forall (f :: * -> *).
DecodeRep f =>
Proxy f -> (GQLTypeOptions, TypeName) -> Info
tags (Proxy f
forall k (t :: k). Proxy t
Proxy @f)
  decodeRep :: (GQLTypeOptions, ValidValue, Cont) -> ResolverState (M1 D d f a)
decodeRep (GQLTypeOptions
ns, ValidValue
x, Cont
y) =
    f a -> M1 D d f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1
      (f a -> M1 D d f a)
-> ResolverStateT () Identity (f a) -> ResolverState (M1 D d f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GQLTypeOptions, ValidValue, Cont)
-> ResolverStateT () Identity (f a)
forall (f :: * -> *) a.
DecodeRep f =>
(GQLTypeOptions, ValidValue, Cont) -> ResolverState (f a)
decodeRep
        (GQLTypeOptions
ns, ValidValue
x, Cont
y {typeName :: TypeName
typeName = Proxy d -> TypeName
forall (f :: Meta -> *) (d :: Meta). Datatype d => f d -> TypeName
datatypeNameProxy (Proxy d
forall k (t :: k). Proxy t
Proxy @d)})

getEnumTag :: ValidObject -> ResolverState TypeName
getEnumTag :: Object VALID -> ResolverState TypeName
getEnumTag Object VALID
x = case Object VALID -> [ObjectEntry VALID]
forall a coll. Elems a coll => coll -> [a]
elems Object VALID
x of
  [ObjectEntry FieldName
"enum" (Enum TypeName
value)] -> TypeName -> ResolverState TypeName
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeName
value
  [ObjectEntry VALID]
_ -> InternalError -> ResolverState TypeName
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (InternalError
"bad union enum object" :: InternalError)

instance (DecodeRep a, DecodeRep b) => DecodeRep (a :+: b) where
  tags :: Proxy (a :+: b) -> (GQLTypeOptions, TypeName) -> Info
tags Proxy (a :+: b)
_ = Proxy a -> (GQLTypeOptions, TypeName) -> Info
forall (f :: * -> *).
DecodeRep f =>
Proxy f -> (GQLTypeOptions, TypeName) -> Info
tags (Proxy a
forall k (t :: k). Proxy t
Proxy @a) ((GQLTypeOptions, TypeName) -> Info)
-> ((GQLTypeOptions, TypeName) -> Info)
-> (GQLTypeOptions, TypeName)
-> Info
forall a. Semigroup a => a -> a -> a
<> Proxy b -> (GQLTypeOptions, TypeName) -> Info
forall (f :: * -> *).
DecodeRep f =>
Proxy f -> (GQLTypeOptions, TypeName) -> Info
tags (Proxy b
forall k (t :: k). Proxy t
Proxy @b)
  decodeRep :: (GQLTypeOptions, ValidValue, Cont) -> ResolverState ((:+:) a b a)
decodeRep = (GQLTypeOptions, ValidValue, Cont) -> ResolverState ((:+:) a b a)
__decode
    where
      __decode :: (GQLTypeOptions, ValidValue, Cont) -> ResolverState ((:+:) a b a)
__decode (GQLTypeOptions
opt, Object Object VALID
obj, Cont
cont) = (TypeName
 -> Object VALID -> Object VALID -> ResolverState ((:+:) a b a))
-> Object VALID -> ResolverState ((:+:) a b a)
forall (m :: * -> *) a.
(Failure InternalError m, Monad m) =>
(TypeName -> Object VALID -> Object VALID -> m a)
-> Object VALID -> m a
withInputUnion TypeName
-> Object VALID -> Object VALID -> ResolverState ((:+:) a b a)
handleUnion Object VALID
obj
        where
          handleUnion :: TypeName
-> Object VALID -> Object VALID -> ResolverState ((:+:) a b a)
handleUnion TypeName
name Object VALID
unions Object VALID
object
            | TypeName
name TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
== Cont -> TypeName
typeName Cont
cont TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> TypeName
"EnumObject" =
              Object VALID -> ResolverState TypeName
getEnumTag Object VALID
object ResolverState TypeName
-> (TypeName -> ResolverState ((:+:) a b a))
-> ResolverState ((:+:) a b a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (GQLTypeOptions, ValidValue, Cont) -> ResolverState ((:+:) a b a)
__decode ((GQLTypeOptions, ValidValue, Cont) -> ResolverState ((:+:) a b a))
-> (TypeName -> (GQLTypeOptions, ValidValue, Cont))
-> TypeName
-> ResolverState ((:+:) a b a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GQLTypeOptions
opt,,Cont
ctx) (ValidValue -> (GQLTypeOptions, ValidValue, Cont))
-> (TypeName -> ValidValue)
-> TypeName
-> (GQLTypeOptions, ValidValue, Cont)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> ValidValue
forall (stage :: Stage). TypeName -> Value stage
Enum
            | [TypeName
name] [TypeName] -> [TypeName] -> Bool
forall a. Eq a => a -> a -> Bool
== [TypeName]
l1 =
              a a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (a a -> (:+:) a b a)
-> ResolverStateT () Identity (a a) -> ResolverState ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GQLTypeOptions, ValidValue, Cont)
-> ResolverStateT () Identity (a a)
forall (f :: * -> *) a.
DecodeRep f =>
(GQLTypeOptions, ValidValue, Cont) -> ResolverState (f a)
decodeRep (GQLTypeOptions
opt, Object VALID -> ValidValue
forall (stage :: Stage). Object stage -> Value stage
Object Object VALID
object, Cont
ctx)
            | [TypeName
name] [TypeName] -> [TypeName] -> Bool
forall a. Eq a => a -> a -> Bool
== [TypeName]
r1 =
              b a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (b a -> (:+:) a b a)
-> ResolverStateT () Identity (b a) -> ResolverState ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GQLTypeOptions, ValidValue, Cont)
-> ResolverStateT () Identity (b a)
forall (f :: * -> *) a.
DecodeRep f =>
(GQLTypeOptions, ValidValue, Cont) -> ResolverState (f a)
decodeRep (GQLTypeOptions
opt, Object VALID -> ValidValue
forall (stage :: Stage). Object stage -> Value stage
Object Object VALID
object, Cont
ctx)
            | Bool
otherwise =
              ([TypeName],
 (GQLTypeOptions, ValidValue, Cont)
 -> ResolverStateT () Identity (a a))
-> ([TypeName],
    (GQLTypeOptions, ValidValue, Cont)
    -> ResolverStateT () Identity (b a))
-> TypeName
-> (GQLTypeOptions, ValidValue, Cont)
-> ResolverState ((:+:) a b a)
forall value (f1 :: * -> *) a (f2 :: * -> *).
([TypeName], value -> ResolverState (f1 a))
-> ([TypeName], value -> ResolverState (f2 a))
-> TypeName
-> value
-> ResolverState ((:+:) f1 f2 a)
decideUnion ([TypeName]
l1, (GQLTypeOptions, ValidValue, Cont)
-> ResolverStateT () Identity (a a)
forall (f :: * -> *) a.
DecodeRep f =>
(GQLTypeOptions, ValidValue, Cont) -> ResolverState (f a)
decodeRep) ([TypeName]
r1, (GQLTypeOptions, ValidValue, Cont)
-> ResolverStateT () Identity (b a)
forall (f :: * -> *) a.
DecodeRep f =>
(GQLTypeOptions, ValidValue, Cont) -> ResolverState (f a)
decodeRep) TypeName
name (GQLTypeOptions
opt, Object VALID -> ValidValue
forall (stage :: Stage). Object stage -> Value stage
Object Object VALID
unions, Cont
ctx)
          l1 :: [TypeName]
l1 = Info -> [TypeName]
tagName Info
l1t
          r1 :: [TypeName]
r1 = Info -> [TypeName]
tagName Info
r1t
          l1t :: Info
l1t = Proxy a -> (GQLTypeOptions, TypeName) -> Info
forall (f :: * -> *).
DecodeRep f =>
Proxy f -> (GQLTypeOptions, TypeName) -> Info
tags (Proxy a
forall k (t :: k). Proxy t
Proxy @a) (GQLTypeOptions
opt, Cont -> TypeName
typeName Cont
cont)
          r1t :: Info
r1t = Proxy b -> (GQLTypeOptions, TypeName) -> Info
forall (f :: * -> *).
DecodeRep f =>
Proxy f -> (GQLTypeOptions, TypeName) -> Info
tags (Proxy b
forall k (t :: k). Proxy t
Proxy @b) (GQLTypeOptions
opt, Cont -> TypeName
typeName Cont
cont)
          ctx :: Cont
ctx = Cont
cont {contKind :: Tag
contKind = Info -> Tag
kind (Info
l1t Info -> Info -> Info
forall a. Semigroup a => a -> a -> a
<> Info
r1t)}
      __decode (GQLTypeOptions
opt, Enum TypeName
name, Cont
cxt) =
        ([TypeName],
 (GQLTypeOptions, ValidValue, Cont)
 -> ResolverStateT () Identity (a a))
-> ([TypeName],
    (GQLTypeOptions, ValidValue, Cont)
    -> ResolverStateT () Identity (b a))
-> TypeName
-> (GQLTypeOptions, ValidValue, Cont)
-> ResolverState ((:+:) a b a)
forall value (f1 :: * -> *) a (f2 :: * -> *).
([TypeName], value -> ResolverState (f1 a))
-> ([TypeName], value -> ResolverState (f2 a))
-> TypeName
-> value
-> ResolverState ((:+:) f1 f2 a)
decideUnion
          (Info -> [TypeName]
tagName (Info -> [TypeName]) -> Info -> [TypeName]
forall a b. (a -> b) -> a -> b
$ Proxy a -> (GQLTypeOptions, TypeName) -> Info
forall (f :: * -> *).
DecodeRep f =>
Proxy f -> (GQLTypeOptions, TypeName) -> Info
tags (Proxy a
forall k (t :: k). Proxy t
Proxy @a) (GQLTypeOptions
opt, Cont -> TypeName
typeName Cont
cxt), (GQLTypeOptions, ValidValue, Cont)
-> ResolverStateT () Identity (a a)
forall (f :: * -> *) a.
DecodeRep f =>
(GQLTypeOptions, ValidValue, Cont) -> ResolverState (f a)
decodeRep)
          (Info -> [TypeName]
tagName (Info -> [TypeName]) -> Info -> [TypeName]
forall a b. (a -> b) -> a -> b
$ Proxy b -> (GQLTypeOptions, TypeName) -> Info
forall (f :: * -> *).
DecodeRep f =>
Proxy f -> (GQLTypeOptions, TypeName) -> Info
tags (Proxy b
forall k (t :: k). Proxy t
Proxy @b) (GQLTypeOptions
opt, Cont -> TypeName
typeName Cont
cxt), (GQLTypeOptions, ValidValue, Cont)
-> ResolverStateT () Identity (b a)
forall (f :: * -> *) a.
DecodeRep f =>
(GQLTypeOptions, ValidValue, Cont) -> ResolverState (f a)
decodeRep)
          TypeName
name
          (GQLTypeOptions
opt, TypeName -> ValidValue
forall (stage :: Stage). TypeName -> Value stage
Enum TypeName
name, Cont
cxt)
      __decode (GQLTypeOptions, ValidValue, Cont)
_ = InternalError -> ResolverState ((:+:) a b a)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (InternalError
"lists and scalars are not allowed in Union" :: InternalError)

instance (Constructor c, DecodeFields a) => DecodeRep (M1 C c a) where
  decodeRep :: (GQLTypeOptions, ValidValue, Cont) -> ResolverState (M1 C c a a)
decodeRep = (a a -> M1 C c a a)
-> ResolverStateT () Identity (a a) -> ResolverState (M1 C c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a a -> M1 C c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (ResolverStateT () Identity (a a) -> ResolverState (M1 C c a a))
-> ((GQLTypeOptions, ValidValue, Cont)
    -> ResolverStateT () Identity (a a))
-> (GQLTypeOptions, ValidValue, Cont)
-> ResolverState (M1 C c a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GQLTypeOptions, ValidValue, Cont)
-> ResolverStateT () Identity (a a)
forall (f :: * -> *) a.
DecodeFields f =>
(GQLTypeOptions, ValidValue, Cont) -> ResolverState (f a)
decodeFields
  tags :: Proxy (M1 C c a) -> (GQLTypeOptions, TypeName) -> Info
tags Proxy (M1 C c a)
_ (GQLTypeOptions
opt, TypeName
baseName) = Maybe TypeName -> Info
getTag (Proxy a -> Maybe TypeName
forall (f :: * -> *). DecodeFields f => Proxy f -> Maybe TypeName
refType (Proxy a
forall k (t :: k). Proxy t
Proxy @a))
    where
      getTag :: Maybe TypeName -> Info
getTag (Just TypeName
memberRef)
        | TypeName -> Bool
isUnionRef TypeName
memberRef = Info :: Tag -> [TypeName] -> Info
Info {kind :: Tag
kind = Tag
D_UNION, tagName :: [TypeName]
tagName = [TypeName
memberRef]}
        | Bool
otherwise = Info :: Tag -> [TypeName] -> Info
Info {kind :: Tag
kind = Tag
D_CONS, tagName :: [TypeName]
tagName = [TypeName
consName]}
      getTag Maybe TypeName
Nothing = Info :: Tag -> [TypeName] -> Info
Info {kind :: Tag
kind = Tag
D_CONS, tagName :: [TypeName]
tagName = [TypeName
consName]}
      --------
      consName :: TypeName
consName = GQLTypeOptions -> Proxy c -> TypeName
forall (f :: Meta -> *) (c :: Meta).
Constructor c =>
GQLTypeOptions -> f c -> TypeName
conNameProxy GQLTypeOptions
opt (Proxy c
forall k (t :: k). Proxy t
Proxy @c)
      ----------
      isUnionRef :: TypeName -> Bool
isUnionRef TypeName
x = TypeName
baseName TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> TypeName
x TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
== TypeName
consName

class DecodeFields f where
  refType :: Proxy f -> Maybe TypeName
  decodeFields :: (GQLTypeOptions, ValidValue, Cont) -> ResolverState (f a)

instance (DecodeFields f, DecodeFields g) => DecodeFields (f :*: g) where
  refType :: Proxy (f :*: g) -> Maybe TypeName
refType Proxy (f :*: g)
_ = Maybe TypeName
forall a. Maybe a
Nothing
  decodeFields :: (GQLTypeOptions, ValidValue, Cont) -> ResolverState ((:*:) f g a)
decodeFields (GQLTypeOptions, ValidValue, Cont)
gql = f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f a -> g a -> (:*:) f g a)
-> ResolverStateT () Identity (f a)
-> ResolverStateT () Identity (g a -> (:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GQLTypeOptions, ValidValue, Cont)
-> ResolverStateT () Identity (f a)
forall (f :: * -> *) a.
DecodeFields f =>
(GQLTypeOptions, ValidValue, Cont) -> ResolverState (f a)
decodeFields (GQLTypeOptions, ValidValue, Cont)
gql ResolverStateT () Identity (g a -> (:*:) f g a)
-> ResolverStateT () Identity (g a) -> ResolverState ((:*:) f g a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (GQLTypeOptions, ValidValue, Cont)
-> ResolverStateT () Identity (g a)
forall (f :: * -> *) a.
DecodeFields f =>
(GQLTypeOptions, ValidValue, Cont) -> ResolverState (f a)
decodeFields (GQLTypeOptions, ValidValue, Cont)
gql

instance (Selector s, GQLType a, Decode a) => DecodeFields (M1 S s (K1 i a)) where
  refType :: Proxy (M1 S s (K1 i a)) -> Maybe TypeName
refType Proxy (M1 S s (K1 i a))
_ = TypeName -> Maybe TypeName
forall a. a -> Maybe a
Just (TypeName -> Maybe TypeName) -> TypeName -> Maybe TypeName
forall a b. (a -> b) -> a -> b
$ TypeData -> TypeName
gqlTypeName (TypeData -> TypeName) -> TypeData -> TypeName
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeData
forall a (f :: * -> *). GQLType a => f a -> TypeData
__type (Proxy a
forall k (t :: k). Proxy t
Proxy @a)
  decodeFields :: (GQLTypeOptions, ValidValue, Cont)
-> ResolverState (M1 S s (K1 i a) a)
decodeFields (GQLTypeOptions
opt, ValidValue
value, Cont {Tag
contKind :: Tag
contKind :: Cont -> Tag
contKind})
    | Tag
contKind Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
D_UNION = K1 i a a -> M1 S s (K1 i a) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 i a a -> M1 S s (K1 i a) a)
-> (a -> K1 i a a) -> a -> M1 S s (K1 i a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> M1 S s (K1 i a) a)
-> ResolverStateT () Identity a
-> ResolverState (M1 S s (K1 i a) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValidValue -> ResolverStateT () Identity a
forall a. Decode a => ValidValue -> ResolverState a
decode ValidValue
value
    | Bool
otherwise = ValidValue -> ResolverState (M1 S s (K1 i a) a)
__decode ValidValue
value
    where
      __decode :: ValidValue -> ResolverState (M1 S s (K1 i a) a)
__decode = (a -> M1 S s (K1 i a) a)
-> ResolverStateT () Identity a
-> ResolverState (M1 S s (K1 i a) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (K1 i a a -> M1 S s (K1 i a) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 i a a -> M1 S s (K1 i a) a)
-> (a -> K1 i a a) -> a -> M1 S s (K1 i a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1) (ResolverStateT () Identity a -> ResolverState (M1 S s (K1 i a) a))
-> (ValidValue -> ResolverStateT () Identity a)
-> ValidValue
-> ResolverState (M1 S s (K1 i a) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidValue -> ResolverStateT () Identity a
decodeRec
      fieldName :: FieldName
fieldName = GQLTypeOptions -> Proxy s -> FieldName
forall (f :: Meta -> *) (s :: Meta).
Selector s =>
GQLTypeOptions -> f s -> FieldName
selNameProxy GQLTypeOptions
opt (Proxy s
forall k (t :: k). Proxy t
Proxy @s)
      decodeRec :: ValidValue -> ResolverStateT () Identity a
decodeRec = (Object VALID -> ResolverStateT () Identity a)
-> ValidValue -> ResolverStateT () Identity a
forall (m :: * -> *) a.
Failure InternalError m =>
(Object VALID -> m a) -> ValidValue -> m a
withInputObject ((ValidValue -> ResolverStateT () Identity a)
-> FieldName -> Object VALID -> ResolverStateT () Identity a
forall (m :: * -> *) a.
(ValidValue -> m a) -> FieldName -> Object VALID -> m a
decodeFieldWith ValidValue -> ResolverStateT () Identity a
forall a. Decode a => ValidValue -> ResolverState a
decode FieldName
fieldName)

instance DecodeFields U1 where
  refType :: Proxy U1 -> Maybe TypeName
refType Proxy U1
_ = Maybe TypeName
forall a. Maybe a
Nothing
  decodeFields :: (GQLTypeOptions, ValidValue, Cont) -> ResolverState (U1 a)
decodeFields (GQLTypeOptions, ValidValue, Cont)
_ = U1 a -> ResolverState (U1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1