{-# 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 qualified Data.HashMap.Lazy as HM
import Data.Morpheus.App.Internal.Resolving.Types
  ( NamedResolverRef (..),
    ObjectTypeResolver (..),
    ResolverValue (..),
    mkList,
    mkNull,
    mkObjectMaybe,
  )
import Data.Morpheus.Internal.Utils (selectOr)
import Data.Morpheus.Types.Internal.AST
  ( GQLError,
    ScalarValue (..),
    TypeName,
    decodeScientific,
    internal,
    packName,
  )
import qualified Data.Vector as V
import Relude

lookupResJSON :: (MonadError GQLError f, Monad m) => Text -> A.Value -> f (ObjectTypeResolver m)
lookupResJSON :: Text -> Value -> f (ObjectTypeResolver m)
lookupResJSON Text
name (A.Object Object
fields) =
  f (ObjectTypeResolver m)
-> (Value -> f (ObjectTypeResolver m))
-> Text
-> 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 -> ResolverValue m) -> Value -> f (ObjectTypeResolver m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ResolverValue m
forall (m :: * -> *). Monad m => Value -> ResolverValue m
mkValue)
    Text
name
    Object
fields
lookupResJSON Text
_ Value
_ = f (ObjectTypeResolver m)
forall (m :: * -> *) (a :: * -> *).
Monad m =>
m (ObjectTypeResolver a)
mkEmptyObject

mkEmptyObject :: Monad m => m (ObjectTypeResolver a)
mkEmptyObject :: m (ObjectTypeResolver a)
mkEmptyObject = ObjectTypeResolver a -> m (ObjectTypeResolver 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 ::
  (Monad m) =>
  A.Value ->
  ResolverValue m
mkValue :: Value -> ResolverValue m
mkValue (A.Object Object
v) =
  Maybe TypeName -> [ResolverEntry m] -> ResolverValue m
forall (m :: * -> *).
Maybe TypeName -> [ResolverEntry m] -> ResolverValue m
mkObjectMaybe
    (Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
"__typename" Object
v Maybe Value -> (Value -> Maybe TypeName) -> Maybe TypeName
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe TypeName
unpackJSONName)
    ([ResolverEntry m] -> ResolverValue m)
-> [ResolverEntry m] -> ResolverValue m
forall a b. (a -> b) -> a -> b
$ ((Text, Value) -> ResolverEntry m)
-> [(Text, Value)] -> [ResolverEntry m]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      ((Text -> FieldName)
-> (Value -> m (ResolverValue m))
-> (Text, Value)
-> ResolverEntry m
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> FieldName
forall (t :: NAME). Text -> Name t
packName (ResolverValue m -> m (ResolverValue m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResolverValue m -> m (ResolverValue m))
-> (Value -> ResolverValue m) -> Value -> m (ResolverValue m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ResolverValue m
forall (m :: * -> *). Monad m => Value -> ResolverValue m
mkValue))
      (Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HM.toList Object
v)
mkValue (A.Array Array
ls) = [ResolverValue m] -> ResolverValue m
forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
mkList ((Value -> ResolverValue m) -> [Value] -> [ResolverValue m]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ResolverValue m
forall (m :: * -> *). Monad m => Value -> ResolverValue m
mkValue (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
ls))
mkValue Value
A.Null = ResolverValue m
forall (m :: * -> *). ResolverValue m
mkNull
mkValue (A.Number Scientific
x) = ScalarValue -> ResolverValue m
forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar (Scientific -> ScalarValue
decodeScientific Scientific
x)
mkValue (A.String Text
x) = ScalarValue -> ResolverValue m
forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar (Text -> ScalarValue
String Text
x)
mkValue (A.Bool Bool
x) = ScalarValue -> ResolverValue m
forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar (Bool -> ScalarValue
Boolean Bool
x)

requireObject :: MonadError GQLError f => ResolverValue m -> f (ObjectTypeResolver m)
requireObject :: ResolverValue m -> f (ObjectTypeResolver m)
requireObject (ResObject Maybe TypeName
_ ObjectTypeResolver m
x) = ObjectTypeResolver m -> f (ObjectTypeResolver m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ObjectTypeResolver m
x
requireObject ResolverValue m
_ = GQLError -> f (ObjectTypeResolver 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) = TypeName -> Maybe TypeName
forall a. a -> Maybe a
Just (Text -> TypeName
forall (t :: NAME). Text -> Name t
packName Text
x)
unpackJSONName Value
_ = Maybe TypeName
forall a. Maybe a
Nothing