{-# 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) =
  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
  ) =>
  Value ->
  f (ResolverValue m)
mkValue :: forall (f :: * -> *) (m :: * -> *).
(MonadReader ResolverContext f, MonadReader ResolverContext m) =>
Value -> f (ResolverValue m)
mkValue (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
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 (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 (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
ls)
mkValue Value
Null = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *). ResolverValue m
mkNull
mkValue (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 (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
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 :: * -> *). Text -> ResolverValue m
mkString Text
v
mkValue (Bool Bool
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Bool -> ResolverValue m
mkBoolean 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 :: Value -> Maybe TypeName
unpackJSONName :: Value -> Maybe TypeName
unpackJSONName (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

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 :: forall (m :: * -> *).
ObjectTypeResolver m -> HashMap FieldName (m (ResolverValue m))
objectFields :: HashMap FieldName (m (ResolverValue m))
..} = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
fb) m (ResolverValue m) -> m' a
suc (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 = forall (m :: * -> *) a.
(MonadReader ResolverContext m, MonadError GQLError m) =>
Maybe TypeName -> m a -> m a
updateCurrentType Maybe TypeName
__typename 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 (forall a. a -> Maybe a
Just SelectionSet VALID
selection)
    checkContent (UnionSelection Maybe (SelectionSet VALID)
interface UnionSelection VALID
unionSel) = do
      TypeName
typename <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolverContext -> TypeDefinition ANY VALID
currentType)
      Maybe (MergeMap 'False FieldName (Selection VALID))
selection <- forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr (forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (SelectionSet VALID)
interface) (forall {f :: * -> *}.
MonadError GQLError f =>
Maybe (MergeMap 'False FieldName (Selection VALID))
-> UnionTag
-> f (Maybe (MergeMap 'False FieldName (Selection VALID)))
fx Maybe (SelectionSet VALID)
interface) TypeName
typename UnionSelection VALID
unionSel
      Maybe (SelectionSet VALID) -> m value
f Maybe (MergeMap 'False FieldName (Selection 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 = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MergeMap 'False FieldName (Selection VALID)
x 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ UnionTag -> SelectionSet VALID
unionTagSelection UnionTag
y
    checkContent SelectionContent VALID
SelectionField = do
      Selection VALID
sel <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ResolverContext -> Selection VALID
currentSelection
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ FieldName -> TypeName -> Position -> GQLError
subfieldsNotSelected (forall (s :: Stage). Selection s -> FieldName
selectionName Selection VALID
sel) TypeName
"" (forall (s :: Stage). Selection s -> Position
selectionPosition Selection VALID
sel)