{-# 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.Types ( NamedResolverRef (..), ObjectTypeResolver (..), ResolverValue (..), mkList, mkNull, mkObjectMaybe, ) import qualified Data.Morpheus.Internal.Utils as U import Data.Morpheus.Internal.Utils (selectOr, toAssoc) import Data.Morpheus.Types.Internal.AST ( FieldName, GQLError, ScalarValue (..), TypeName, decodeScientific, internal, packName, unpackName, ) import qualified Data.Vector as V import Relude lookupResJSON :: (MonadError GQLError f, Monad m) => FieldName -> A.Value -> f (ObjectTypeResolver m) lookupResJSON :: FieldName -> Value -> f (ObjectTypeResolver m) lookupResJSON FieldName name (A.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 -> 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) (FieldName -> Key forall a (t :: NAME). NamePacking a => Name t -> a 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 :: 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 (Key -> Object -> Maybe Value forall k (m :: * -> *) a. IsMap k m => k -> m a -> Maybe a U.lookup Key "__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 $ ((Key, Value) -> ResolverEntry m) -> [(Key, Value)] -> [ResolverEntry m] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ((Key -> FieldName) -> (Value -> m (ResolverValue m)) -> (Key, Value) -> ResolverEntry m 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 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 -> [(Key, Value)] forall k (m :: * -> *) a. IsMap k m => m a -> [(k, a)] toAssoc 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 a (t :: NAME). NamePacking a => a -> Name t packName Text x) unpackJSONName Value _ = Maybe TypeName forall a. Maybe a Nothing