{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.App.Internal.Resolving.Utils
  ( ResolverValue (..),
    requireObject,
    NamedResolverRef (..),
    ObjectTypeResolver,
    lookupResJSON,
    mkValue,
  )
where

import Control.Monad.Except (MonadError (throwError))
import qualified Data.Aeson as A
import Data.Morpheus.App.Internal.Resolving.ResolverState
import Data.Morpheus.App.Internal.Resolving.Types
  ( NamedResolverRef (..),
    ObjectTypeResolver (..),
    ResolverValue (..),
    mkList,
    mkNull,
    mkObjectMaybe,
  )
import Data.Morpheus.Internal.Utils (selectOr, toAssoc)
import qualified Data.Morpheus.Internal.Utils as U
import Data.Morpheus.Types.Internal.AST
  ( FieldName,
    GQLError,
    ScalarValue (..),
    TypeName,
    decodeScientific,
    internal,
    packName,
    unpackName,
  )
import Data.Morpheus.Types.SelectionTree (SelectionTree (..))
import Data.Text (breakOnEnd, splitOn)
import qualified Data.Vector as V
import Relude hiding (break)

lookupResJSON ::
  ( MonadError GQLError f,
    MonadReader ResolverContext f,
    MonadReader ResolverContext m
  ) =>
  FieldName ->
  A.Value ->
  f (ObjectTypeResolver m)
lookupResJSON :: forall (f :: * -> *) (m :: * -> *).
(MonadError GQLError f, MonadReader ResolverContext f,
 MonadReader ResolverContext m) =>
FieldName -> Value -> f (ObjectTypeResolver m)
lookupResJSON FieldName
name (A.Object Object
fields) =
  forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr
    forall (m :: * -> *) (a :: * -> *).
Monad m =>
m (ObjectTypeResolver a)
mkEmptyObject
    (forall (f :: * -> *) (m :: * -> *).
MonadError GQLError f =>
ResolverValue m -> f (ObjectTypeResolver m)
requireObject forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (f :: * -> *) (m :: * -> *).
(MonadReader ResolverContext f, MonadReader ResolverContext m) =>
Value -> f (ResolverValue m)
mkValue)
    (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName FieldName
name)
    Object
fields
lookupResJSON FieldName
_ Value
_ = forall (m :: * -> *) (a :: * -> *).
Monad m =>
m (ObjectTypeResolver a)
mkEmptyObject

mkEmptyObject :: Monad m => m (ObjectTypeResolver a)
mkEmptyObject :: forall (m :: * -> *) (a :: * -> *).
Monad m =>
m (ObjectTypeResolver a)
mkEmptyObject = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m
ObjectTypeResolver forall a. Monoid a => a
mempty

mkValue ::
  ( MonadReader ResolverContext f,
    MonadReader ResolverContext m
  ) =>
  A.Value ->
  f (ResolverValue m)
mkValue :: forall (f :: * -> *) (m :: * -> *).
(MonadReader ResolverContext f, MonadReader ResolverContext m) =>
Value -> f (ResolverValue m)
mkValue (A.Object Object
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Maybe TypeName -> [ResolverEntry m] -> ResolverValue m
mkObjectMaybe Maybe TypeName
typename [(FieldName, m (ResolverValue m))]
fields
  where
    typename :: Maybe TypeName
typename = forall k (m :: * -> *) a. IsMap k m => k -> m a -> Maybe a
U.lookup Key
"__typename" Object
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe TypeName
unpackJSONName
    fields :: [(FieldName, m (ResolverValue m))]
fields = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a (t :: NAME). NamePacking a => a -> Name t
packName forall (f :: * -> *) (m :: * -> *).
(MonadReader ResolverContext f, MonadReader ResolverContext m) =>
Value -> f (ResolverValue m)
mkValue) (forall k (m :: * -> *) a. IsMap k m => m a -> [(k, a)]
toAssoc Object
v)
mkValue (A.Array Array
ls) = forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
mkList 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 (f :: * -> *) (m :: * -> *).
(MonadReader ResolverContext f, MonadReader ResolverContext m) =>
Value -> f (ResolverValue m)
mkValue (forall a. Vector a -> [a]
V.toList Array
ls)
mkValue Value
A.Null = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *). ResolverValue m
mkNull
mkValue (A.Number Scientific
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar (Scientific -> ScalarValue
decodeScientific Scientific
x)
mkValue (A.String Text
txt) = case Text -> SelfAPI
withSelf Text
txt of
  ARG Text
name -> do
    Selection VALID
sel <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ResolverContext -> Selection VALID
currentSelection
    forall (f :: * -> *) (m :: * -> *).
(MonadReader ResolverContext f, MonadReader ResolverContext m) =>
Value -> f (ResolverValue m)
mkValue (forall a. a -> Maybe a -> a
fromMaybe Value
A.Null (forall node name.
(SelectionTree node, ToString name) =>
name -> node -> Maybe Value
getArgument Text
name Selection VALID
sel))
  NoAPI Text
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar (Text -> ScalarValue
String Text
v)
mkValue (A.Bool Bool
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar (Bool -> ScalarValue
Boolean Bool
x)

data SelfAPI
  = ARG Text
  | NoAPI Text

withSelf :: Text -> SelfAPI
withSelf :: Text -> SelfAPI
withSelf Text
txt = case Text -> Text -> (Text, Text)
breakOnEnd Text
"::" Text
txt of
  (Text
"@SELF::", Text
field) -> case Text -> Text -> [Text]
splitOn Text
"." Text
field of
    [Text
"ARG", Text
name] -> Text -> SelfAPI
ARG Text
name
    [Text]
_ -> Text -> SelfAPI
NoAPI Text
txt
  (Text, Text)
_ -> Text -> SelfAPI
NoAPI Text
txt

requireObject :: MonadError GQLError f => ResolverValue m -> f (ObjectTypeResolver m)
requireObject :: forall (f :: * -> *) (m :: * -> *).
MonadError GQLError f =>
ResolverValue m -> f (ObjectTypeResolver m)
requireObject (ResObject Maybe TypeName
_ ObjectTypeResolver m
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ObjectTypeResolver m
x
requireObject ResolverValue m
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"resolver must be an object")

unpackJSONName :: A.Value -> Maybe TypeName
unpackJSONName :: Value -> Maybe TypeName
unpackJSONName (A.String Text
x) = forall a. a -> Maybe a
Just (forall a (t :: NAME). NamePacking a => a -> Name t
packName Text
x)
unpackJSONName Value
_ = forall a. Maybe a
Nothing