{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Internal.Decode.Rep
  ( DecodeRep (..),
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.Morpheus.Server.Deriving.Internal.Decode.Utils
  ( Context (..),
    CountFields (..),
    DecoderT,
    DescribeCons,
    decodeFieldWith,
    getFieldName,
    getUnionInfos,
    setVariantRef,
    withInputObject,
    withInputUnion,
  )
import Data.Morpheus.Server.Deriving.Utils.Proxy
  ( selNameProxy,
  )
import Data.Morpheus.Server.Deriving.Utils.Use
  ( UseDeriving (..),
    UseValue (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( Object,
    TypeName,
    VALID,
    ValidObject,
    ValidValue,
    Value (..),
    internal,
    msg,
  )
import GHC.Generics
import Relude

decideEither ::
  (DecodeRep gql args f, DecodeRep gql args g) =>
  UseDeriving gql args ->
  ([TypeName], [TypeName]) ->
  TypeName ->
  ValidValue ->
  DecoderT ((f :+: g) a)
decideEither :: forall (gql :: * -> Constraint) (args :: * -> Constraint)
       (f :: * -> *) (g :: * -> *) a.
(DecodeRep gql args f, DecodeRep gql args g) =>
UseDeriving gql args
-> ([TypeName], [TypeName])
-> TypeName
-> ValidValue
-> DecoderT ((:+:) f g a)
decideEither UseDeriving gql args
dir ([TypeName]
left, [TypeName]
right) TypeName
name ValidValue
value
  | TypeName
name forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TypeName]
left = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (gql :: * -> Constraint) (args :: * -> Constraint)
       (f :: * -> *) a.
DecodeRep gql args f =>
UseDeriving gql args -> ValidValue -> DecoderT (f a)
decodeRep UseDeriving gql args
dir ValidValue
value
  | TypeName
name forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TypeName]
right = forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (gql :: * -> Constraint) (args :: * -> Constraint)
       (f :: * -> *) a.
DecodeRep gql args f =>
UseDeriving gql args -> ValidValue -> DecoderT (f a)
decodeRep UseDeriving gql args
dir ValidValue
value
  | Bool
otherwise =
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
        GQLError -> GQLError
internal forall a b. (a -> b) -> a -> b
$
          GQLError
"Constructor \""
            forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg TypeName
name
            forall a. Semigroup a => a -> a -> a
<> GQLError
"\" could not find in Union"

decodeInputUnionObject ::
  (DecodeRep gql args f, DecodeRep gql args g) =>
  UseDeriving gql args ->
  ([TypeName], [TypeName]) ->
  TypeName ->
  Object VALID ->
  ValidObject ->
  DecoderT ((f :+: g) a)
decodeInputUnionObject :: forall (gql :: * -> Constraint) (args :: * -> Constraint)
       (f :: * -> *) (g :: * -> *) a.
(DecodeRep gql args f, DecodeRep gql args g) =>
UseDeriving gql args
-> ([TypeName], [TypeName])
-> TypeName
-> Object VALID
-> Object VALID
-> DecoderT ((:+:) f g a)
decodeInputUnionObject UseDeriving gql args
dir ([TypeName]
l, [TypeName]
r) TypeName
name Object VALID
unions Object VALID
object
  | [TypeName
name] forall a. Eq a => a -> a -> Bool
== [TypeName]
l = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (gql :: * -> Constraint) (args :: * -> Constraint)
       (f :: * -> *) a.
DecodeRep gql args f =>
UseDeriving gql args -> ValidValue -> DecoderT (f a)
decodeRep UseDeriving gql args
dir (forall (stage :: Stage). Object stage -> Value stage
Object Object VALID
object)
  | [TypeName
name] forall a. Eq a => a -> a -> Bool
== [TypeName]
r = forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (gql :: * -> Constraint) (args :: * -> Constraint)
       (f :: * -> *) a.
DecodeRep gql args f =>
UseDeriving gql args -> ValidValue -> DecoderT (f a)
decodeRep UseDeriving gql args
dir (forall (stage :: Stage). Object stage -> Value stage
Object Object VALID
object)
  | Bool
otherwise = forall (gql :: * -> Constraint) (args :: * -> Constraint)
       (f :: * -> *) (g :: * -> *) a.
(DecodeRep gql args f, DecodeRep gql args g) =>
UseDeriving gql args
-> ([TypeName], [TypeName])
-> TypeName
-> ValidValue
-> DecoderT ((:+:) f g a)
decideEither UseDeriving gql args
dir ([TypeName]
l, [TypeName]
r) TypeName
name (forall (stage :: Stage). Object stage -> Value stage
Object Object VALID
unions)

class DecodeRep gql args (f :: Type -> Type) where
  decodeRep :: UseDeriving gql args -> ValidValue -> DecoderT (f a)

instance (Datatype d, DecodeRep gql args f) => DecodeRep gql args (M1 D d f) where
  decodeRep :: forall a.
UseDeriving gql args -> ValidValue -> DecoderT (M1 D d f a)
decodeRep UseDeriving gql args
dir ValidValue
value = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (gql :: * -> Constraint) (args :: * -> Constraint)
       (f :: * -> *) a.
DecodeRep gql args f =>
UseDeriving gql args -> ValidValue -> DecoderT (f a)
decodeRep UseDeriving gql args
dir ValidValue
value

instance (DescribeCons gql a, DescribeCons gql b, DecodeRep gql args a, DecodeRep gql args b) => DecodeRep gql args (a :+: b) where
  decodeRep :: forall a.
UseDeriving gql args -> ValidValue -> DecoderT ((:+:) a b a)
decodeRep UseDeriving gql args
dir (Object Object VALID
obj) =
    do
      (Bool
kind, ([TypeName], [TypeName])
lr) <- forall (f :: (* -> *) -> *) (a :: * -> *) (b :: * -> *)
       (gql :: * -> Constraint).
(DescribeCons gql a, DescribeCons gql b) =>
UseGQLType gql
-> f (a :+: b) -> DecoderT (Bool, ([TypeName], [TypeName]))
getUnionInfos (forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseGQLType gql
dirGQL UseDeriving gql args
dir) (forall {k} (t :: k). Proxy t
Proxy @(a :+: b))
      forall a. Bool -> DecoderT a -> DecoderT a
setVariantRef Bool
kind forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadError GQLError m, Monad m) =>
(TypeName -> Object VALID -> Object VALID -> m a)
-> Object VALID -> m a
withInputUnion (forall (gql :: * -> Constraint) (args :: * -> Constraint)
       (f :: * -> *) (g :: * -> *) a.
(DecodeRep gql args f, DecodeRep gql args g) =>
UseDeriving gql args
-> ([TypeName], [TypeName])
-> TypeName
-> Object VALID
-> Object VALID
-> DecoderT ((:+:) f g a)
decodeInputUnionObject UseDeriving gql args
dir ([TypeName], [TypeName])
lr) Object VALID
obj
  decodeRep UseDeriving gql args
dir (Enum TypeName
name) = do
    (Bool
_, ([TypeName]
l, [TypeName]
r)) <- forall (f :: (* -> *) -> *) (a :: * -> *) (b :: * -> *)
       (gql :: * -> Constraint).
(DescribeCons gql a, DescribeCons gql b) =>
UseGQLType gql
-> f (a :+: b) -> DecoderT (Bool, ([TypeName], [TypeName]))
getUnionInfos (forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseGQLType gql
dirGQL UseDeriving gql args
dir) (forall {k} (t :: k). Proxy t
Proxy @(a :+: b))
    TypeName -> TypeName
visitor <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> TypeName -> TypeName
enumVisitor
    forall (gql :: * -> Constraint) (args :: * -> Constraint)
       (f :: * -> *) (g :: * -> *) a.
(DecodeRep gql args f, DecodeRep gql args g) =>
UseDeriving gql args
-> ([TypeName], [TypeName])
-> TypeName
-> ValidValue
-> DecoderT ((:+:) f g a)
decideEither UseDeriving gql args
dir (forall a b. (a -> b) -> [a] -> [b]
map TypeName -> TypeName
visitor [TypeName]
l, forall a b. (a -> b) -> [a] -> [b]
map TypeName -> TypeName
visitor [TypeName]
r) TypeName
name (forall (stage :: Stage). TypeName -> Value stage
Enum TypeName
name)
  decodeRep UseDeriving gql args
_ ValidValue
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"lists and scalars are not allowed in Union")

instance (Constructor c, DecodeFields gql args a) => DecodeRep gql args (M1 C c a) where
  decodeRep :: forall a.
UseDeriving gql args -> ValidValue -> DecoderT (M1 C c a a)
decodeRep UseDeriving gql args
dir = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (gql :: * -> Constraint) (args :: * -> Constraint)
       (f :: * -> *) a.
DecodeFields gql args f =>
UseDeriving gql args -> Int -> ValidValue -> DecoderT (f a)
decodeFields UseDeriving gql args
dir Int
0

class DecodeFields gql args (f :: Type -> Type) where
  decodeFields :: UseDeriving gql args -> Int -> ValidValue -> DecoderT (f a)

instance (DecodeFields gql args f, DecodeFields gql args g, CountFields g) => DecodeFields gql args (f :*: g) where
  decodeFields :: forall a.
UseDeriving gql args -> Int -> ValidValue -> DecoderT ((:*:) f g a)
decodeFields UseDeriving gql args
dir Int
index ValidValue
gql =
    forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (gql :: * -> Constraint) (args :: * -> Constraint)
       (f :: * -> *) a.
DecodeFields gql args f =>
UseDeriving gql args -> Int -> ValidValue -> DecoderT (f a)
decodeFields UseDeriving gql args
dir Int
index ValidValue
gql
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (gql :: * -> Constraint) (args :: * -> Constraint)
       (f :: * -> *) a.
DecodeFields gql args f =>
UseDeriving gql args -> Int -> ValidValue -> DecoderT (f a)
decodeFields UseDeriving gql args
dir (Int
index forall a. Num a => a -> a -> a
+ forall (f :: * -> *). CountFields f => Proxy f -> Int
countFields (forall {k} (t :: k). Proxy t
Proxy @g)) ValidValue
gql

instance (Selector s, args a) => DecodeFields gql args (M1 S s (K1 i a)) where
  decodeFields :: forall a.
UseDeriving gql args
-> Int -> ValidValue -> DecoderT (M1 S s (K1 i a) a)
decodeFields UseDeriving {UseValue args
dirArgs :: forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseValue val
dirArgs :: UseValue args
dirArgs} Int
index ValidValue
value =
    forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      Context {Bool
isVariantRef :: Context -> Bool
isVariantRef :: Bool
isVariantRef, FieldName -> FieldName
fieldVisitor :: Context -> FieldName -> FieldName
fieldVisitor :: FieldName -> FieldName
fieldVisitor} <- forall r (m :: * -> *). MonadReader r m => m r
ask
      if Bool
isVariantRef
        then forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (val :: * -> Constraint).
UseValue val -> forall a. val a => ValidValue -> ResolverState a
useDecodeValue UseValue args
dirArgs ValidValue
value)
        else
          let fieldName :: FieldName
fieldName = FieldName -> FieldName
fieldVisitor forall a b. (a -> b) -> a -> b
$ FieldName -> Int -> FieldName
getFieldName (forall (f :: Meta -> *) (s :: Meta). Selector s => f s -> FieldName
selNameProxy (forall {k} (t :: k). Proxy t
Proxy @s)) Int
index
              fieldDecoder :: Object VALID -> ReaderT Context ResolverState a
fieldDecoder = forall (m :: * -> *) a.
(ValidValue -> m a) -> FieldName -> Object VALID -> m a
decodeFieldWith (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (val :: * -> Constraint).
UseValue val -> forall a. val a => ValidValue -> ResolverState a
useDecodeValue UseValue args
dirArgs) FieldName
fieldName
           in forall (m :: * -> *) a.
MonadError GQLError m =>
(Object VALID -> m a) -> ValidValue -> m a
withInputObject Object VALID -> ReaderT Context ResolverState a
fieldDecoder ValidValue
value

instance DecodeFields gql args U1 where
  decodeFields :: forall a.
UseDeriving gql args -> Int -> ValidValue -> DecoderT (U1 a)
decodeFields UseDeriving gql args
_ Int
_ ValidValue
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k (p :: k). U1 p
U1