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

module Data.Morpheus.Server.Deriving.Internal.Value
  ( DecodeRep (..),
    Context (..),
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.Morpheus.App.Internal.Resolving (ResolverState)
import Data.Morpheus.Generic
  ( CProxy (..),
    DecodeFields,
    DecoderFun (..),
    DescribeCons,
    decodeFields,
    describeCons,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded (inputType)
import Data.Morpheus.Server.Deriving.Utils.Types (coerceInputObject, getField)
import Data.Morpheus.Server.Deriving.Utils.Use
  ( UseDeriving (..),
    UseGQLType (..),
    UseGQLValue (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( FieldName,
    TypeName,
    ValidValue,
    Value (..),
    getInputUnionValue,
    internal,
    msg,
  )
import GHC.Generics
import Relude

data Context = Context
  { Context -> Bool
isVariantRef :: Bool,
    Context -> TypeName
typeName :: TypeName,
    Context -> TypeName -> TypeName
enumVisitor :: TypeName -> TypeName,
    Context -> FieldName -> FieldName
fieldVisitor :: FieldName -> FieldName
  }

type DecoderT = ReaderT Context ResolverState

setVariantRef :: Bool -> DecoderT a -> DecoderT a
setVariantRef :: forall a. Bool -> DecoderT a -> DecoderT a
setVariantRef Bool
isVariantRef = (Context -> Context)
-> ReaderT Context ResolverState a
-> ReaderT Context ResolverState a
forall a.
(Context -> Context)
-> ReaderT Context ResolverState a
-> ReaderT Context ResolverState a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Context
ctx -> Context
ctx {isVariantRef})

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

class DecodeRep ctx (f :: Type -> Type) where
  decodeRep :: ctx -> ValidValue -> DecoderT (f a)

instance (Datatype d, DecodeRep ctx f) => DecodeRep ctx (M1 D d f) where
  decodeRep :: forall a. ctx -> ValidValue -> DecoderT (M1 D d f a)
decodeRep ctx
drv ValidValue
value = 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)
-> ReaderT Context ResolverState (f a)
-> ReaderT Context ResolverState (M1 D d f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ctx -> ValidValue -> ReaderT Context ResolverState (f a)
forall a. ctx -> ValidValue -> DecoderT (f a)
forall ctx (f :: * -> *) a.
DecodeRep ctx f =>
ctx -> ValidValue -> DecoderT (f a)
decodeRep ctx
drv ValidValue
value

instance (UseGQLType ctx gql, DescribeCons gql a, DescribeCons gql b, DecodeRep ctx a, DecodeRep ctx b) => DecodeRep ctx (a :+: b) where
  decodeRep :: forall a. ctx -> ValidValue -> DecoderT ((:+:) a b a)
decodeRep ctx
ctx ValidValue
input =
    do
      TypeName
typename <- (Context -> TypeName) -> ReaderT Context ResolverState TypeName
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> TypeName
typeName
      let (Bool
kind, ([TypeName]
left, [TypeName]
right)) = ctx
-> TypeName -> Proxy (a :+: b) -> (Bool, ([TypeName], [TypeName]))
forall ctx (f :: (* -> *) -> *) (a :: * -> *) (b :: * -> *)
       (gql :: * -> Constraint).
(UseGQLType ctx gql, DescribeCons gql a, DescribeCons gql b) =>
ctx -> TypeName -> f (a :+: b) -> (Bool, ([TypeName], [TypeName]))
getUnionTags ctx
ctx TypeName
typename (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @(a :+: b))
      (([TypeName], [TypeName])
lr, TypeName
name, ValidValue
value) <-
        case ValidValue
input of
          (Object Object VALID
obj) -> do
            (TypeName
name, ValidValue
value) <- Object VALID
-> ReaderT Context ResolverState (TypeName, ValidValue)
forall (m :: * -> *) (stage :: Stage).
MonadError GQLError m =>
Object stage -> m (TypeName, Value stage)
getInputUnionValue Object VALID
obj
            Object VALID
variant <- ValidValue -> ReaderT Context ResolverState (Object VALID)
forall (m :: * -> *).
MonadError GQLError m =>
ValidValue -> m (Object VALID)
coerceInputObject ValidValue
value
            let isDone :: Bool
isDone = [TypeName
name] [TypeName] -> [TypeName] -> Bool
forall a. Eq a => a -> a -> Bool
== [TypeName]
left Bool -> Bool -> Bool
|| [TypeName
name] [TypeName] -> [TypeName] -> Bool
forall a. Eq a => a -> a -> Bool
== [TypeName]
left
            (([TypeName], [TypeName]), TypeName, ValidValue)
-> ReaderT
     Context
     ResolverState
     (([TypeName], [TypeName]), TypeName, ValidValue)
forall a. a -> ReaderT Context ResolverState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([TypeName]
left, [TypeName]
right), TypeName
name, if Bool
isDone then Object VALID -> ValidValue
forall (stage :: Stage). Object stage -> Value stage
Object Object VALID
variant else ValidValue
input)
          (Enum TypeName
name) -> do
            TypeName -> TypeName
visitor <- (Context -> TypeName -> TypeName)
-> ReaderT Context ResolverState (TypeName -> TypeName)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> TypeName -> TypeName
enumVisitor
            (([TypeName], [TypeName]), TypeName, ValidValue)
-> ReaderT
     Context
     ResolverState
     (([TypeName], [TypeName]), TypeName, ValidValue)
forall a. a -> ReaderT Context ResolverState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((TypeName -> TypeName) -> [TypeName] -> [TypeName]
forall a b. (a -> b) -> [a] -> [b]
map TypeName -> TypeName
visitor [TypeName]
left, (TypeName -> TypeName) -> [TypeName] -> [TypeName]
forall a b. (a -> b) -> [a] -> [b]
map TypeName -> TypeName
visitor [TypeName]
right), TypeName
name, TypeName -> ValidValue
forall (stage :: Stage). TypeName -> Value stage
Enum TypeName
name)
          ValidValue
_ -> GQLError
-> ReaderT
     Context
     ResolverState
     (([TypeName], [TypeName]), TypeName, ValidValue)
forall a. GQLError -> ReaderT Context ResolverState a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"lists and scalars are not allowed in Union")
      Bool -> DecoderT ((:+:) a b a) -> DecoderT ((:+:) a b a)
forall a. Bool -> DecoderT a -> DecoderT a
setVariantRef Bool
kind (ctx
-> ([TypeName], [TypeName])
-> TypeName
-> ValidValue
-> DecoderT ((:+:) a b a)
forall ctx (f :: * -> *) (g :: * -> *) a.
(DecodeRep ctx f, DecodeRep ctx g) =>
ctx
-> ([TypeName], [TypeName])
-> TypeName
-> ValidValue
-> DecoderT ((:+:) f g a)
decideUnion ctx
ctx ([TypeName], [TypeName])
lr TypeName
name ValidValue
value)

instance (Constructor c, UseDeriving gql val ~ ctx, DecodeFields val a) => DecodeRep ctx (M1 C c a) where
  decodeRep :: forall a. ctx -> ValidValue -> DecoderT (M1 C c a a)
decodeRep ctx
ctx ValidValue
value = (a a -> M1 C c a a)
-> ReaderT Context ResolverState (a a)
-> ReaderT Context ResolverState (M1 C c a a)
forall a b.
(a -> b)
-> ReaderT Context ResolverState a
-> ReaderT Context ResolverState b
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 (DecoderFun val (ReaderT Context ResolverState)
-> ReaderT Context ResolverState (a a)
forall (m :: * -> *) (con :: * -> Constraint) (f :: * -> *) a.
(Monad m, DecodeFields con f) =>
DecoderFun con m -> m (f a)
decodeFields (ctx -> ValidValue -> DecoderFun val (ReaderT Context ResolverState)
forall ctx (con :: * -> Constraint).
UseGQLValue ctx con =>
ctx -> ValidValue -> DecoderFun con (ReaderT Context ResolverState)
decoder ctx
ctx ValidValue
value))

decoder :: (UseGQLValue ctx con) => ctx -> ValidValue -> DecoderFun con DecoderT
decoder :: forall ctx (con :: * -> Constraint).
UseGQLValue ctx con =>
ctx -> ValidValue -> DecoderFun con (ReaderT Context ResolverState)
decoder ctx
ctx ValidValue
input =
  (forall a. con a => FieldName -> DecoderT a)
-> DecoderFun con (ReaderT Context ResolverState)
forall (con :: * -> Constraint) (m :: * -> *).
(forall a. con a => FieldName -> m a) -> DecoderFun con m
DecoderFun
    ( \FieldName
name ->
        do
          Context {Bool
isVariantRef :: Context -> Bool
isVariantRef :: Bool
isVariantRef, FieldName -> FieldName
fieldVisitor :: Context -> FieldName -> FieldName
fieldVisitor :: FieldName -> FieldName
fieldVisitor} <- DecoderT Context
forall r (m :: * -> *). MonadReader r m => m r
ask
          ValidValue
value <- if Bool
isVariantRef then ValidValue -> DecoderT ValidValue
forall a. a -> ReaderT Context ResolverState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidValue
input else FieldName -> Object VALID -> ValidValue
getField (FieldName -> FieldName
fieldVisitor FieldName
name) (Object VALID -> ValidValue)
-> ReaderT Context ResolverState (Object VALID)
-> DecoderT ValidValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValidValue -> ReaderT Context ResolverState (Object VALID)
forall (m :: * -> *).
MonadError GQLError m =>
ValidValue -> m (Object VALID)
coerceInputObject ValidValue
input
          ResolverState a -> DecoderT a
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ctx -> ValidValue -> ResolverState a
forall a. con a => ctx -> ValidValue -> ResolverState a
forall ctx (con :: * -> Constraint) a.
(UseGQLValue ctx con, con a) =>
ctx -> ValidValue -> ResolverState a
useDecodeValue ctx
ctx ValidValue
value)
    )

getUnionTags ::
  forall ctx f a b gql.
  (UseGQLType ctx gql, DescribeCons gql a, DescribeCons gql b) =>
  ctx ->
  TypeName ->
  f (a :+: b) ->
  (Bool, ([TypeName], [TypeName]))
getUnionTags :: forall ctx (f :: (* -> *) -> *) (a :: * -> *) (b :: * -> *)
       (gql :: * -> Constraint).
(UseGQLType ctx gql, DescribeCons gql a, DescribeCons gql b) =>
ctx -> TypeName -> f (a :+: b) -> (Bool, ([TypeName], [TypeName]))
getUnionTags ctx
ctx TypeName
typename f (a :+: b)
_ = do
  let left :: [(TypeName, Bool)]
left = ((TypeName, Maybe (CProxy gql)) -> (TypeName, Bool))
-> [(TypeName, Maybe (CProxy gql))] -> [(TypeName, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (TypeName, Maybe (CProxy gql)) -> (TypeName, Bool)
toInfo (Proxy a -> [(TypeName, Maybe (CProxy gql))]
forall t. IsString t => Proxy a -> [(t, Maybe (CProxy gql))]
forall (con :: * -> Constraint) (f :: * -> *) t.
(DescribeCons con f, IsString t) =>
Proxy f -> [(t, Maybe (CProxy con))]
describeCons (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @a))
  let right :: [(TypeName, Bool)]
right = ((TypeName, Maybe (CProxy gql)) -> (TypeName, Bool))
-> [(TypeName, Maybe (CProxy gql))] -> [(TypeName, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (TypeName, Maybe (CProxy gql)) -> (TypeName, Bool)
toInfo (Proxy b -> [(TypeName, Maybe (CProxy gql))]
forall t. IsString t => Proxy b -> [(t, Maybe (CProxy gql))]
forall (con :: * -> Constraint) (f :: * -> *) t.
(DescribeCons con f, IsString t) =>
Proxy f -> [(t, Maybe (CProxy con))]
describeCons (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @b))
  let varRef :: Maybe (TypeName, Bool)
varRef = ((TypeName, Bool) -> Bool)
-> [(TypeName, Bool)] -> Maybe (TypeName, Bool)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TypeName, Bool) -> Bool
forall a b. (a, b) -> b
snd ([(TypeName, Bool)]
left [(TypeName, Bool)] -> [(TypeName, Bool)] -> [(TypeName, Bool)]
forall a. Semigroup a => a -> a -> a
<> [(TypeName, Bool)]
right)
  (Maybe (TypeName, Bool) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (TypeName, Bool)
varRef, (((TypeName, Bool) -> TypeName) -> [(TypeName, Bool)] -> [TypeName]
forall a b. (a -> b) -> [a] -> [b]
map (TypeName, Bool) -> TypeName
forall a b. (a, b) -> a
fst [(TypeName, Bool)]
left, ((TypeName, Bool) -> TypeName) -> [(TypeName, Bool)] -> [TypeName]
forall a b. (a -> b) -> [a] -> [b]
map (TypeName, Bool) -> TypeName
forall a b. (a, b) -> a
fst [(TypeName, Bool)]
right))
  where
    toInfo :: (TypeName, Maybe (CProxy gql)) -> (TypeName, Bool)
    toInfo :: (TypeName, Maybe (CProxy gql)) -> (TypeName, Bool)
toInfo (TypeName
consName, Just (CProxy f a
p))
      | TypeName
consName TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
== TypeName
typename TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> TypeName
typeVariant = (TypeName
typeVariant, Bool
True)
      | Bool
otherwise = (TypeName
consName, Bool
False)
      where
        typeVariant :: TypeName
typeVariant = ctx -> CatType IN a -> TypeName
forall a (c :: TypeCategory).
gql a =>
ctx -> CatType c a -> TypeName
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> TypeName
useTypename ctx
ctx (f a -> CatType IN a
forall {k} (f :: k -> *) (a :: k). f a -> CatType IN a
inputType f a
p)
    toInfo (TypeName
consName, Maybe (CProxy gql)
Nothing) = (TypeName
consName, Bool
False)