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

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

import Control.Monad.Except (MonadError (throwError))
import Data.Aeson (Value (..))
import Data.Morpheus.App.Internal.Resolving.ResolverState
  ( ResolverContext (..),
    updateCurrentType,
  )
import Data.Morpheus.App.Internal.Resolving.Types
  ( NamedResolverRef (..),
    ObjectTypeResolver (..),
    ResolverValue (..),
    mkBoolean,
    mkList,
    mkNull,
    mkObjectMaybe,
    mkString,
  )
import Data.Morpheus.Error (subfieldsNotSelected)
import Data.Morpheus.Internal.Utils (IsMap (..), selectOr, toAssoc, (<:>))
import Data.Morpheus.Types.Internal.AST
  ( FieldName,
    GQLError,
    Selection (..),
    SelectionContent (..),
    SelectionSet,
    TypeDefinition (..),
    TypeName,
    UnionTag (..),
    VALID,
    decodeScientific,
    internal,
    packName,
    unpackName,
  )
import Data.Morpheus.Types.SelectionTree (SelectionTree (..))
import Data.Text (breakOnEnd, splitOn)
import Relude hiding (break)

type ResolverMonad m = (MonadError GQLError m, MonadReader ResolverContext m)

lookupResJSON ::
  (ResolverMonad f, MonadReader ResolverContext m) =>
  FieldName ->
  Value ->
  f (ObjectTypeResolver m)
lookupResJSON :: forall (f :: * -> *) (m :: * -> *).
(ResolverMonad f, MonadReader ResolverContext m) =>
FieldName -> Value -> f (ObjectTypeResolver m)
lookupResJSON FieldName
name (Object Object
fields) =
  f (ObjectTypeResolver m)
-> (Value -> f (ObjectTypeResolver m))
-> Key
-> Object
-> f (ObjectTypeResolver m)
forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr
    f (ObjectTypeResolver m)
forall (m :: * -> *) (a :: * -> *).
Monad m =>
m (ObjectTypeResolver a)
mkEmptyObject
    (ResolverValue m -> f (ObjectTypeResolver m)
forall (f :: * -> *) (m :: * -> *).
MonadError GQLError f =>
ResolverValue m -> f (ObjectTypeResolver m)
requireObject (ResolverValue m -> f (ObjectTypeResolver m))
-> (Value -> f (ResolverValue m))
-> Value
-> f (ObjectTypeResolver m)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Value -> f (ResolverValue m)
forall (f :: * -> *) (m :: * -> *).
(MonadReader ResolverContext f, MonadReader ResolverContext m) =>
Value -> f (ResolverValue m)
mkValue)
    (FieldName -> Key
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Key
unpackName FieldName
name)
    Object
fields
lookupResJSON FieldName
_ Value
_ = f (ObjectTypeResolver m)
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 = ObjectTypeResolver a -> m (ObjectTypeResolver a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ObjectTypeResolver a -> m (ObjectTypeResolver a))
-> ObjectTypeResolver a -> m (ObjectTypeResolver a)
forall a b. (a -> b) -> a -> b
$ HashMap FieldName (a (ResolverValue a)) -> ObjectTypeResolver a
forall (m :: * -> *).
HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m
ObjectTypeResolver HashMap FieldName (a (ResolverValue a))
forall a. Monoid a => a
mempty

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

data SelfAPI
  = ARG Text
  | NoAPI Text

withSelf :: Text -> SelfAPI
withSelf :: Text -> SelfAPI
withSelf Text
txt = case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
breakOnEnd Text
"::" Text
txt of
  (Text
"@SELF::", Text
field) -> case HasCallStack => Text -> Text -> [Text]
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) = ObjectTypeResolver m -> f (ObjectTypeResolver m)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ObjectTypeResolver m
x
requireObject ResolverValue m
_ = GQLError -> f (ObjectTypeResolver m)
forall a. GQLError -> f a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"resolver must be an object")

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

withField :: Monad m' => a -> (m (ResolverValue m) -> m' a) -> FieldName -> ObjectTypeResolver m -> m' a
withField :: forall (m' :: * -> *) a (m :: * -> *).
Monad m' =>
a
-> (m (ResolverValue m) -> m' a)
-> FieldName
-> ObjectTypeResolver m
-> m' a
withField a
fb m (ResolverValue m) -> m' a
suc FieldName
selectionName ObjectTypeResolver {HashMap FieldName (m (ResolverValue m))
objectFields :: HashMap FieldName (m (ResolverValue m))
objectFields :: forall (m :: * -> *).
ObjectTypeResolver m -> HashMap FieldName (m (ResolverValue m))
..} = m' a
-> (m (ResolverValue m) -> m' a)
-> Maybe (m (ResolverValue m))
-> m' a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> m' a
forall a. a -> m' a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
fb) m (ResolverValue m) -> m' a
suc (FieldName
-> HashMap FieldName (m (ResolverValue m))
-> Maybe (m (ResolverValue m))
forall a. FieldName -> HashMap FieldName a -> Maybe a
forall k (m :: * -> *) a. IsMap k m => k -> m a -> Maybe a
lookup FieldName
selectionName HashMap FieldName (m (ResolverValue m))
objectFields)

withObject ::
  (ResolverMonad m) =>
  Maybe TypeName ->
  (Maybe (SelectionSet VALID) -> m value) ->
  SelectionContent VALID ->
  m value
withObject :: forall (m :: * -> *) value.
ResolverMonad m =>
Maybe TypeName
-> (Maybe (SelectionSet VALID) -> m value)
-> SelectionContent VALID
-> m value
withObject Maybe TypeName
__typename Maybe (SelectionSet VALID) -> m value
f = Maybe TypeName -> m value -> m value
forall (m :: * -> *) a.
(MonadReader ResolverContext m, MonadError GQLError m) =>
Maybe TypeName -> m a -> m a
updateCurrentType Maybe TypeName
__typename (m value -> m value)
-> (SelectionContent VALID -> m value)
-> SelectionContent VALID
-> m value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SelectionContent VALID -> m value
checkContent
  where
    checkContent :: SelectionContent VALID -> m value
checkContent (SelectionSet SelectionSet VALID
selection) = Maybe (SelectionSet VALID) -> m value
f (MergeMap 'False FieldName (Selection VALID)
-> Maybe (MergeMap 'False FieldName (Selection VALID))
forall a. a -> Maybe a
Just MergeMap 'False FieldName (Selection VALID)
SelectionSet VALID
selection)
    checkContent (UnionSelection Maybe (SelectionSet VALID)
interface UnionSelection VALID
unionSel) = do
      TypeName
typename <- (ResolverContext -> TypeName) -> m TypeName
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (TypeDefinition ANY VALID -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName (TypeDefinition ANY VALID -> TypeName)
-> (ResolverContext -> TypeDefinition ANY VALID)
-> ResolverContext
-> TypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolverContext -> TypeDefinition ANY VALID
currentType)
      Maybe (MergeMap 'False FieldName (Selection VALID))
selection <- m (Maybe (MergeMap 'False FieldName (Selection VALID)))
-> (UnionTag
    -> m (Maybe (MergeMap 'False FieldName (Selection VALID))))
-> TypeName
-> MergeMap 'False TypeName UnionTag
-> m (Maybe (MergeMap 'False FieldName (Selection VALID)))
forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr (Maybe (MergeMap 'False FieldName (Selection VALID))
-> m (Maybe (MergeMap 'False FieldName (Selection VALID)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (MergeMap 'False FieldName (Selection VALID))
Maybe (SelectionSet VALID)
interface) (Maybe (MergeMap 'False FieldName (Selection VALID))
-> UnionTag
-> m (Maybe (MergeMap 'False FieldName (Selection VALID)))
forall {f :: * -> *}.
MonadError GQLError f =>
Maybe (MergeMap 'False FieldName (Selection VALID))
-> UnionTag
-> f (Maybe (MergeMap 'False FieldName (Selection VALID)))
fx Maybe (MergeMap 'False FieldName (Selection VALID))
Maybe (SelectionSet VALID)
interface) TypeName
typename MergeMap 'False TypeName UnionTag
UnionSelection VALID
unionSel
      Maybe (SelectionSet VALID) -> m value
f Maybe (MergeMap 'False FieldName (Selection VALID))
Maybe (SelectionSet VALID)
selection
      where
        fx :: Maybe (MergeMap 'False FieldName (Selection VALID))
-> UnionTag
-> f (Maybe (MergeMap 'False FieldName (Selection VALID)))
fx (Just MergeMap 'False FieldName (Selection VALID)
x) UnionTag
y = MergeMap 'False FieldName (Selection VALID)
-> Maybe (MergeMap 'False FieldName (Selection VALID))
forall a. a -> Maybe a
Just (MergeMap 'False FieldName (Selection VALID)
 -> Maybe (MergeMap 'False FieldName (Selection VALID)))
-> f (MergeMap 'False FieldName (Selection VALID))
-> f (Maybe (MergeMap 'False FieldName (Selection VALID)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MergeMap 'False FieldName (Selection VALID)
x MergeMap 'False FieldName (Selection VALID)
-> MergeMap 'False FieldName (Selection VALID)
-> f (MergeMap 'False FieldName (Selection VALID))
forall (m :: * -> *) a.
(Merge (HistoryT m) a, Monad m) =>
a -> a -> m a
<:> UnionTag -> SelectionSet VALID
unionTagSelection UnionTag
y)
        fx Maybe (MergeMap 'False FieldName (Selection VALID))
Nothing UnionTag
y = Maybe (MergeMap 'False FieldName (Selection VALID))
-> f (Maybe (MergeMap 'False FieldName (Selection VALID)))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (MergeMap 'False FieldName (Selection VALID))
 -> f (Maybe (MergeMap 'False FieldName (Selection VALID))))
-> Maybe (MergeMap 'False FieldName (Selection VALID))
-> f (Maybe (MergeMap 'False FieldName (Selection VALID)))
forall a b. (a -> b) -> a -> b
$ SelectionSet VALID -> Maybe (SelectionSet VALID)
forall a. a -> Maybe a
Just (SelectionSet VALID -> Maybe (SelectionSet VALID))
-> SelectionSet VALID -> Maybe (SelectionSet VALID)
forall a b. (a -> b) -> a -> b
$ UnionTag -> SelectionSet VALID
unionTagSelection UnionTag
y
    checkContent SelectionContent VALID
SelectionField = do
      Selection VALID
sel <- (ResolverContext -> Selection VALID) -> m (Selection VALID)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ResolverContext -> Selection VALID
currentSelection
      GQLError -> m value
forall a. GQLError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> m value) -> GQLError -> m value
forall a b. (a -> b) -> a -> b
$ FieldName -> TypeName -> Position -> GQLError
subfieldsNotSelected (Selection VALID -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName Selection VALID
sel) TypeName
"" (Selection VALID -> Position
forall (s :: Stage). Selection s -> Position
selectionPosition Selection VALID
sel)