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

module Data.Morpheus.Server.Deriving.Internal.Decode.Utils
  ( withInputObject,
    withEnum,
    withInputUnion,
    decodeFieldWith,
    withScalar,
    handleEither,
    getFieldName,
    DecoderT,
    setVariantRef,
    Context (..),
    getUnionInfos,
    DescribeCons,
    CountFields (..),
    RefType (..),
    repValue,
    useDecodeArguments,
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.Morpheus.App.Internal.Resolving (ResolverState)
import Data.Morpheus.Internal.Ext (GQLResult)
import Data.Morpheus.Internal.Utils
  ( fromElems,
    selectOr,
  )
import Data.Morpheus.Server.Deriving.Utils.AST (argumentsToObject)
import Data.Morpheus.Server.Deriving.Utils.GRep
  ( ConsRep (..),
    FieldRep (..),
    TypeRep (..),
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CatType (..),
  )
import Data.Morpheus.Server.Deriving.Utils.Proxy
  ( conNameProxy,
  )
import Data.Morpheus.Server.Deriving.Utils.Use (UseDeriving, UseGQLType (useTypename), UseValue (..), dirArgs)
import Data.Morpheus.Types.GQLScalar
  ( toScalar,
  )
import Data.Morpheus.Types.Internal.AST
  ( Arguments,
    CONST,
    FieldName,
    GQLError,
    IN,
    Msg (msg),
    ObjectEntry (..),
    ScalarValue,
    Token,
    TypeName,
    VALID,
    ValidObject,
    ValidValue,
    Value (..),
    getInputUnionValue,
    internal,
  )
import GHC.Generics
import Relude

repValue ::
  TypeRep (GQLResult (Value CONST)) ->
  GQLResult (Value CONST)
repValue :: TypeRep (GQLResult (Value CONST)) -> GQLResult (Value CONST)
repValue
  TypeRep
    { Bool
tyIsUnion :: forall v. TypeRep v -> Bool
tyIsUnion :: Bool
tyIsUnion,
      tyCons :: forall v. TypeRep v -> ConsRep v
tyCons = ConsRep {[FieldRep (GQLResult (Value CONST))]
consFields :: forall v. ConsRep v -> [FieldRep v]
consFields :: [FieldRep (GQLResult (Value CONST))]
consFields, TypeName
consName :: forall v. ConsRep v -> TypeName
consName :: TypeName
consName}
    } = [FieldRep (GQLResult (Value CONST))] -> GQLResult (Value CONST)
encodeTypeFields [FieldRep (GQLResult (Value CONST))]
consFields
    where
      encodeTypeFields ::
        [FieldRep (GQLResult (Value CONST))] -> GQLResult (Value CONST)
      encodeTypeFields :: [FieldRep (GQLResult (Value CONST))] -> GQLResult (Value CONST)
encodeTypeFields [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (stage :: Stage). TypeName -> Value stage
Enum TypeName
consName
      encodeTypeFields [FieldRep (GQLResult (Value CONST))]
fields | Bool -> Bool
not Bool
tyIsUnion = forall (stage :: Stage). Object stage -> Value stage
Object forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *} {s :: Stage}.
Monad m =>
FieldRep (m (Value s)) -> m (ObjectEntry s)
fromField [FieldRep (GQLResult (Value CONST))]
fields forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems)
        where
          fromField :: FieldRep (m (Value s)) -> m (ObjectEntry s)
fromField FieldRep {FieldName
fieldSelector :: forall a. FieldRep a -> FieldName
fieldSelector :: FieldName
fieldSelector, m (Value s)
fieldValue :: forall a. FieldRep a -> a
fieldValue :: m (Value s)
fieldValue} = do
            Value s
entryValue <- m (Value s)
fieldValue
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ObjectEntry {entryName :: FieldName
entryName = FieldName
fieldSelector, Value s
entryValue :: Value s
entryValue :: Value s
entryValue}
      -- Type References --------------------------------------------------------------
      encodeTypeFields [FieldRep (GQLResult (Value CONST))]
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"input unions are not supported")

withInputObject ::
  MonadError GQLError m =>
  (ValidObject -> m a) ->
  ValidValue ->
  m a
withInputObject :: forall (m :: * -> *) a.
MonadError GQLError m =>
(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 = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch GQLError
"InputObject" ValidValue
isType)

-- | Useful for more restrictive instances of lists (non empty, size indexed etc)
withEnum :: MonadError GQLError m => (TypeName -> m a) -> Value VALID -> m a
withEnum :: forall (m :: * -> *) a.
MonadError GQLError m =>
(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 = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch GQLError
"Enum" ValidValue
isType)

withInputUnion ::
  (MonadError GQLError m, Monad m) =>
  (TypeName -> ValidObject -> ValidObject -> m a) ->
  ValidObject ->
  m a
withInputUnion :: forall (m :: * -> *) a.
(MonadError GQLError m, Monad m) =>
(TypeName -> ValidObject -> ValidObject -> m a)
-> ValidObject -> m a
withInputUnion TypeName -> ValidObject -> ValidObject -> m a
decoder ValidObject
unions =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {a}. GQLError -> m a
onFail (TypeName, ValidValue) -> m a
onSuccess (forall (stage :: Stage).
Object stage -> Either GQLError (TypeName, Value stage)
getInputUnionValue ValidObject
unions)
  where
    onSuccess :: (TypeName, ValidValue) -> m a
onSuccess (TypeName
name, ValidValue
value) = forall (m :: * -> *) a.
MonadError GQLError m =>
(ValidObject -> m a) -> ValidValue -> m a
withInputObject (TypeName -> ValidObject -> ValidObject -> m a
decoder TypeName
name ValidObject
unions) ValidValue
value
    onFail :: GQLError -> m a
onFail = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. GQLError -> GQLError
internal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Msg a => a -> GQLError
msg

withScalar ::
  (Applicative m, MonadError GQLError m) =>
  TypeName ->
  (ScalarValue -> Either Token a) ->
  Value VALID ->
  m a
withScalar :: forall (m :: * -> *) a.
(Applicative m, MonadError GQLError m) =>
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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ScalarValue -> Either Token a
decodeScalar of
  Right a
scalar -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
scalar
  Left Token
message ->
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
      ( forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch
          (GQLError
"SCALAR(" forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg TypeName
typename forall a. Semigroup a => a -> a -> a
<> GQLError
")" forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg Token
message)
          ValidValue
value
      )

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

handleEither :: MonadError GQLError m => Either GQLError a -> m a
handleEither :: forall (m :: * -> *) a.
MonadError GQLError m =>
Either GQLError a -> m a
handleEither = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- if value is already validated but value has different type
typeMismatch :: GQLError -> Value s -> GQLError
typeMismatch :: forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch GQLError
text Value s
jsType =
  GQLError -> GQLError
internal forall a b. (a -> b) -> a -> b
$
    GQLError
"Type mismatch! expected:"
      forall a. Semigroup a => a -> a -> a
<> GQLError
text
      forall a. Semigroup a => a -> a -> a
<> GQLError
", got: "
      forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg Value s
jsType

getFieldName :: FieldName -> Int -> FieldName
getFieldName :: FieldName -> Int -> FieldName
getFieldName FieldName
"" Int
index = FieldName
"_" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Int
index
getFieldName FieldName
label Int
_ = FieldName
label

data VariantKind = InlineVariant | VariantRef deriving (VariantKind -> VariantKind -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VariantKind -> VariantKind -> Bool
$c/= :: VariantKind -> VariantKind -> Bool
== :: VariantKind -> VariantKind -> Bool
$c== :: VariantKind -> VariantKind -> Bool
Eq, Eq VariantKind
VariantKind -> VariantKind -> Bool
VariantKind -> VariantKind -> Ordering
VariantKind -> VariantKind -> VariantKind
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 :: VariantKind -> VariantKind -> VariantKind
$cmin :: VariantKind -> VariantKind -> VariantKind
max :: VariantKind -> VariantKind -> VariantKind
$cmax :: VariantKind -> VariantKind -> VariantKind
>= :: VariantKind -> VariantKind -> Bool
$c>= :: VariantKind -> VariantKind -> Bool
> :: VariantKind -> VariantKind -> Bool
$c> :: VariantKind -> VariantKind -> Bool
<= :: VariantKind -> VariantKind -> Bool
$c<= :: VariantKind -> VariantKind -> Bool
< :: VariantKind -> VariantKind -> Bool
$c< :: VariantKind -> VariantKind -> Bool
compare :: VariantKind -> VariantKind -> Ordering
$ccompare :: VariantKind -> VariantKind -> Ordering
Ord)

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

instance Semigroup Info where
  Info VariantKind
VariantRef [TypeName]
t1 <> :: Info -> Info -> Info
<> Info VariantKind
_ [TypeName]
t2 = VariantKind -> [TypeName] -> Info
Info VariantKind
VariantRef ([TypeName]
t1 forall a. Semigroup a => a -> a -> a
<> [TypeName]
t2)
  Info VariantKind
_ [TypeName]
t1 <> Info VariantKind
VariantRef [TypeName]
t2 = VariantKind -> [TypeName] -> Info
Info VariantKind
VariantRef ([TypeName]
t1 forall a. Semigroup a => a -> a -> a
<> [TypeName]
t2)
  Info VariantKind
InlineVariant [TypeName]
t1 <> Info VariantKind
InlineVariant [TypeName]
t2 = VariantKind -> [TypeName] -> Info
Info VariantKind
InlineVariant ([TypeName]
t1 forall a. Semigroup a => a -> a -> a
<> [TypeName]
t2)

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 = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Context
ctx -> Context
ctx {Bool
isVariantRef :: Bool
isVariantRef :: Bool
isVariantRef})

class DescribeCons gql (f :: Type -> Type) where
  tags :: UseGQLType gql -> Proxy f -> Context -> Info

instance (Datatype d, DescribeCons gql f) => DescribeCons gql (M1 D d f) where
  tags :: UseGQLType gql -> Proxy (M1 D d f) -> Context -> Info
tags UseGQLType gql
ctx Proxy (M1 D d f)
_ = forall (gql :: * -> Constraint) (f :: * -> *).
DescribeCons gql f =>
UseGQLType gql -> Proxy f -> Context -> Info
tags UseGQLType gql
ctx (forall {k} (t :: k). Proxy t
Proxy @f)

instance (DescribeCons gql a, DescribeCons gql b) => DescribeCons gql (a :+: b) where
  tags :: UseGQLType gql -> Proxy (a :+: b) -> Context -> Info
tags UseGQLType gql
ctx Proxy (a :+: b)
_ = forall (gql :: * -> Constraint) (f :: * -> *).
DescribeCons gql f =>
UseGQLType gql -> Proxy f -> Context -> Info
tags UseGQLType gql
ctx (forall {k} (t :: k). Proxy t
Proxy @a) forall a. Semigroup a => a -> a -> a
<> forall (gql :: * -> Constraint) (f :: * -> *).
DescribeCons gql f =>
UseGQLType gql -> Proxy f -> Context -> Info
tags UseGQLType gql
ctx (forall {k} (t :: k). Proxy t
Proxy @b)

instance (Constructor c, CountFields a, RefType gql a) => DescribeCons gql (M1 C c a) where
  tags :: UseGQLType gql -> Proxy (M1 C c a) -> Context -> Info
tags UseGQLType gql
ctx Proxy (M1 C c a)
_ Context {TypeName
typeName :: TypeName
typeName :: Context -> TypeName
typeName} = Maybe TypeName -> Info
getTag (forall (gql :: * -> Constraint) (f :: * -> *).
RefType gql f =>
UseGQLType gql -> Proxy f -> Maybe TypeName
refType UseGQLType gql
ctx (forall {k} (t :: k). Proxy t
Proxy @a))
    where
      getTag :: Maybe TypeName -> Info
getTag (Just TypeName
memberRef)
        | TypeName -> Bool
isUnionRef TypeName
memberRef = Info {kind :: VariantKind
kind = VariantKind
VariantRef, tagName :: [TypeName]
tagName = [TypeName
memberRef]}
        | Bool
otherwise = Info {kind :: VariantKind
kind = VariantKind
InlineVariant, tagName :: [TypeName]
tagName = [TypeName
consName]}
      getTag Maybe TypeName
Nothing = Info {kind :: VariantKind
kind = VariantKind
InlineVariant, tagName :: [TypeName]
tagName = [TypeName
consName]}
      --------
      consName :: TypeName
consName = forall (f :: Meta -> *) (c :: Meta).
Constructor c =>
f c -> TypeName
conNameProxy (forall {k} (t :: k). Proxy t
Proxy @c)
      ----------
      isUnionRef :: TypeName -> Bool
isUnionRef TypeName
x = TypeName
typeName forall a. Semigroup a => a -> a -> a
<> TypeName
x forall a. Eq a => a -> a -> Bool
== TypeName
consName

getUnionInfos ::
  forall f a b gql.
  (DescribeCons gql a, DescribeCons gql b) =>
  UseGQLType gql ->
  f (a :+: b) ->
  DecoderT (Bool, ([TypeName], [TypeName]))
getUnionInfos :: forall (f :: (* -> *) -> *) (a :: * -> *) (b :: * -> *)
       (gql :: * -> Constraint).
(DescribeCons gql a, DescribeCons gql b) =>
UseGQLType gql
-> f (a :+: b) -> DecoderT (Bool, ([TypeName], [TypeName]))
getUnionInfos UseGQLType gql
ctx f (a :+: b)
_ = do
  Context
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
  let l :: Info
l = forall (gql :: * -> Constraint) (f :: * -> *).
DescribeCons gql f =>
UseGQLType gql -> Proxy f -> Context -> Info
tags UseGQLType gql
ctx (forall {k} (t :: k). Proxy t
Proxy @a) Context
context
  let r :: Info
r = forall (gql :: * -> Constraint) (f :: * -> *).
DescribeCons gql f =>
UseGQLType gql -> Proxy f -> Context -> Info
tags UseGQLType gql
ctx (forall {k} (t :: k). Proxy t
Proxy @b) Context
context
  let k :: VariantKind
k = Info -> VariantKind
kind (Info
l forall a. Semigroup a => a -> a -> a
<> Info
r)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (VariantKind
k forall a. Eq a => a -> a -> Bool
== VariantKind
VariantRef, (Info -> [TypeName]
tagName Info
l, Info -> [TypeName]
tagName Info
r))

class RefType gql (f :: Type -> Type) where
  refType :: UseGQLType gql -> Proxy f -> Maybe TypeName

instance (RefType gql f, RefType gql g) => RefType gql (f :*: g) where
  refType :: UseGQLType gql -> Proxy (f :*: g) -> Maybe TypeName
refType UseGQLType gql
_ Proxy (f :*: g)
_ = forall a. Maybe a
Nothing

instance (Selector s, gql a) => RefType gql (M1 S s (K1 i a)) where
  refType :: UseGQLType gql -> Proxy (M1 S s (K1 i a)) -> Maybe TypeName
refType UseGQLType gql
dir Proxy (M1 S s (K1 i a))
_ = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (gql :: * -> Constraint).
UseGQLType gql
-> forall (c :: TypeCategory) a. gql a => CatType c a -> TypeName
useTypename UseGQLType gql
dir (forall {k} (a :: k). CatType IN a
InputType :: CatType IN a)

instance RefType gql U1 where
  refType :: UseGQLType gql -> Proxy U1 -> Maybe TypeName
refType UseGQLType gql
_ Proxy U1
_ = forall a. Maybe a
Nothing

class CountFields (f :: Type -> Type) where
  countFields :: Proxy f -> Int

instance (CountFields f, CountFields g) => CountFields (f :*: g) where
  countFields :: Proxy (f :*: g) -> Int
countFields Proxy (f :*: g)
_ = forall (f :: * -> *). CountFields f => Proxy f -> Int
countFields (forall {k} (t :: k). Proxy t
Proxy @f) forall a. Num a => a -> a -> a
+ forall (f :: * -> *). CountFields f => Proxy f -> Int
countFields (forall {k} (t :: k). Proxy t
Proxy @g)

instance (Selector s) => CountFields (M1 S s (K1 i a)) where
  countFields :: Proxy (M1 S s (K1 i a)) -> Int
countFields Proxy (M1 S s (K1 i a))
_ = Int
1

instance CountFields U1 where
  countFields :: Proxy U1 -> Int
countFields Proxy U1
_ = Int
0

useDecodeArguments :: val a => UseDeriving gql val -> Arguments VALID -> ResolverState a
useDecodeArguments :: forall (val :: * -> Constraint) a (gql :: * -> Constraint).
val a =>
UseDeriving gql val -> Arguments VALID -> ResolverState a
useDecodeArguments UseDeriving gql val
drv = forall (val :: * -> Constraint).
UseValue val -> forall a. val a => ValidValue -> ResolverState a
useDecodeValue (forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseValue val
dirArgs UseDeriving gql val
drv) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arguments VALID -> ValidValue
argumentsToObject