{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.App.Internal.Resolving.Types
( ResolverMap,
NamedResolver (..),
NamedResolverResult (..),
NamedResolverRef (..),
ResolverValue (..),
ObjectTypeResolver (..),
ResolverEntry,
mkEnum,
mkBoolean,
mkFloat,
mkInt,
mkList,
mkNull,
mkString,
mkObject,
mkObjectMaybe,
mkUnion,
)
where
import Control.Monad.Except (MonadError (throwError))
import qualified Data.HashMap.Lazy as HM
import Data.Morpheus.Internal.Ext (Merge (..))
import Data.Morpheus.Internal.Utils (KeyOf (keyOf))
import Data.Morpheus.Types.Internal.AST
( FieldName,
GQLError,
ScalarValue (..),
TypeName,
ValidValue,
internal,
)
import GHC.Show (Show (show))
import Relude hiding (show)
type ResolverMap (m :: Type -> Type) = HashMap TypeName (NamedResolver m)
data NamedResolver (m :: Type -> Type) = NamedResolver
{ NamedResolver m -> TypeName
resolverName :: TypeName,
NamedResolver m -> ValidValue -> m (NamedResolverResult m)
resolver :: ValidValue -> m (NamedResolverResult m)
}
instance Show (NamedResolver m) where
show :: NamedResolver m -> String
show NamedResolver {TypeName
ValidValue -> m (NamedResolverResult m)
resolver :: ValidValue -> m (NamedResolverResult m)
resolverName :: TypeName
resolver :: forall (m :: * -> *).
NamedResolver m -> ValidValue -> m (NamedResolverResult m)
resolverName :: forall (m :: * -> *). NamedResolver m -> TypeName
..} =
String
"NamedResolver { name = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeName -> String
forall a. Show a => a -> String
show TypeName
resolverName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" }"
newtype ObjectTypeResolver m = ObjectTypeResolver
{ ObjectTypeResolver m -> HashMap FieldName (m (ResolverValue m))
objectFields :: HashMap FieldName (m (ResolverValue m))
}
instance Show (ObjectTypeResolver m) where
show :: ObjectTypeResolver m -> String
show ObjectTypeResolver m
_ = String
"ObjectTypeResolver {}"
data NamedResolverRef = NamedResolverRef
{ NamedResolverRef -> TypeName
resolverTypeName :: TypeName,
NamedResolverRef -> ValidValue
resolverArgument :: ValidValue
}
deriving (Int -> NamedResolverRef -> ShowS
[NamedResolverRef] -> ShowS
NamedResolverRef -> String
(Int -> NamedResolverRef -> ShowS)
-> (NamedResolverRef -> String)
-> ([NamedResolverRef] -> ShowS)
-> Show NamedResolverRef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NamedResolverRef] -> ShowS
$cshowList :: [NamedResolverRef] -> ShowS
show :: NamedResolverRef -> String
$cshow :: NamedResolverRef -> String
showsPrec :: Int -> NamedResolverRef -> ShowS
$cshowsPrec :: Int -> NamedResolverRef -> ShowS
Show)
data NamedResolverResult (m :: Type -> Type)
= NamedObjectResolver (ObjectTypeResolver m)
| NamedUnionResolver NamedResolverRef
| NamedEnumResolver TypeName
instance KeyOf TypeName (NamedResolver m) where
keyOf :: NamedResolver m -> TypeName
keyOf = NamedResolver m -> TypeName
forall (m :: * -> *). NamedResolver m -> TypeName
resolverName
data ResolverValue (m :: Type -> Type)
= ResNull
| ResScalar ScalarValue
| ResList [ResolverValue m]
| ResEnum TypeName
| ResObject (Maybe TypeName) (ObjectTypeResolver m)
| ResRef (m NamedResolverRef)
| ResLazy (m (ResolverValue m))
instance
( Monad m,
Applicative f,
MonadError GQLError m
) =>
Merge f (ObjectTypeResolver m)
where
merge :: ObjectTypeResolver m
-> ObjectTypeResolver m -> f (ObjectTypeResolver m)
merge (ObjectTypeResolver HashMap FieldName (m (ResolverValue m))
x) (ObjectTypeResolver HashMap FieldName (m (ResolverValue m))
y) =
ObjectTypeResolver m -> f (ObjectTypeResolver m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ObjectTypeResolver m -> f (ObjectTypeResolver m))
-> ObjectTypeResolver m -> f (ObjectTypeResolver m)
forall a b. (a -> b) -> a -> b
$ HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m
forall (m :: * -> *).
HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m
ObjectTypeResolver ((m (ResolverValue m) -> m (ResolverValue m) -> m (ResolverValue m))
-> HashMap FieldName (m (ResolverValue m))
-> HashMap FieldName (m (ResolverValue m))
-> HashMap FieldName (m (ResolverValue m))
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HM.unionWith m (ResolverValue m) -> m (ResolverValue m) -> m (ResolverValue m)
forall (m :: * -> *) b. (Monad m, Merge m b) => m b -> m b -> m b
mergeFields HashMap FieldName (m (ResolverValue m))
x HashMap FieldName (m (ResolverValue m))
y)
where
mergeFields :: m b -> m b -> m b
mergeFields m b
a m b
b = (,) (b -> b -> (b, b)) -> m b -> m (b -> (b, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
a m (b -> (b, b)) -> m b -> m (b, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m b
b m (b, b) -> ((b, b) -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> b -> m b) -> (b, b) -> m b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry b -> b -> m b
forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge
instance Show (ResolverValue m) where
show :: ResolverValue m -> String
show ResolverValue m
_ = String
"ResolverValue {}"
instance IsString (ResolverValue m) where
fromString :: String -> ResolverValue m
fromString = ScalarValue -> ResolverValue m
forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar (ScalarValue -> ResolverValue m)
-> (String -> ScalarValue) -> String -> ResolverValue m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ScalarValue
forall a. IsString a => String -> a
fromString
instance
( Monad f,
MonadError GQLError f,
Merge f (ObjectTypeResolver m)
) =>
Merge f (ResolverValue m)
where
merge :: ResolverValue m -> ResolverValue m -> f (ResolverValue m)
merge ResolverValue m
ResNull ResolverValue m
ResNull = ResolverValue m -> f (ResolverValue m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResolverValue m
forall (m :: * -> *). ResolverValue m
ResNull
merge ResScalar {} x :: ResolverValue m
x@ResScalar {} = ResolverValue m -> f (ResolverValue m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResolverValue m
x
merge ResEnum {} x :: ResolverValue m
x@ResEnum {} = ResolverValue m -> f (ResolverValue m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResolverValue m
x
merge (ResObject Maybe TypeName
n ObjectTypeResolver m
x) (ResObject Maybe TypeName
_ ObjectTypeResolver m
y) = Maybe TypeName -> ObjectTypeResolver m -> ResolverValue m
forall (m :: * -> *).
Maybe TypeName -> ObjectTypeResolver m -> ResolverValue m
ResObject Maybe TypeName
n (ObjectTypeResolver m -> ResolverValue m)
-> f (ObjectTypeResolver m) -> f (ResolverValue m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ObjectTypeResolver m
-> ObjectTypeResolver m -> f (ObjectTypeResolver m)
forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge ObjectTypeResolver m
x ObjectTypeResolver m
y
merge ResolverValue m
_ ResolverValue m
_ = GQLError -> f (ResolverValue m)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"can't merge: incompatible resolvers")
type ResolverEntry m = (FieldName, m (ResolverValue m))
mkString :: Text -> ResolverValue m
mkString :: Text -> ResolverValue m
mkString = ScalarValue -> ResolverValue m
forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar (ScalarValue -> ResolverValue m)
-> (Text -> ScalarValue) -> Text -> ResolverValue m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ScalarValue
String
mkFloat :: Double -> ResolverValue m
mkFloat :: Double -> ResolverValue m
mkFloat = ScalarValue -> ResolverValue m
forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar (ScalarValue -> ResolverValue m)
-> (Double -> ScalarValue) -> Double -> ResolverValue m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> ScalarValue
Float
mkInt :: Int -> ResolverValue m
mkInt :: Int -> ResolverValue m
mkInt = ScalarValue -> ResolverValue m
forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar (ScalarValue -> ResolverValue m)
-> (Int -> ScalarValue) -> Int -> ResolverValue m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ScalarValue
Int
mkBoolean :: Bool -> ResolverValue m
mkBoolean :: Bool -> ResolverValue m
mkBoolean = ScalarValue -> ResolverValue m
forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar (ScalarValue -> ResolverValue m)
-> (Bool -> ScalarValue) -> Bool -> ResolverValue m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ScalarValue
Boolean
mkList :: [ResolverValue m] -> ResolverValue m
mkList :: [ResolverValue m] -> ResolverValue m
mkList = [ResolverValue m] -> ResolverValue m
forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
ResList
mkNull :: ResolverValue m
mkNull :: ResolverValue m
mkNull = ResolverValue m
forall (m :: * -> *). ResolverValue m
ResNull
mkEnum :: TypeName -> ResolverValue m
mkEnum :: TypeName -> ResolverValue m
mkEnum = TypeName -> ResolverValue m
forall (m :: * -> *). TypeName -> ResolverValue m
ResEnum
mkObject ::
TypeName ->
[ResolverEntry m] ->
ResolverValue m
mkObject :: TypeName -> [ResolverEntry m] -> ResolverValue m
mkObject TypeName
name = Maybe TypeName -> [ResolverEntry m] -> ResolverValue m
forall (m :: * -> *).
Maybe TypeName -> [ResolverEntry m] -> ResolverValue m
mkObjectMaybe (TypeName -> Maybe TypeName
forall a. a -> Maybe a
Just TypeName
name)
mkObjectMaybe ::
Maybe TypeName ->
[ResolverEntry m] ->
ResolverValue m
mkObjectMaybe :: Maybe TypeName -> [ResolverEntry m] -> ResolverValue m
mkObjectMaybe Maybe TypeName
name = Maybe TypeName -> ObjectTypeResolver m -> ResolverValue m
forall (m :: * -> *).
Maybe TypeName -> ObjectTypeResolver m -> ResolverValue m
ResObject Maybe TypeName
name (ObjectTypeResolver m -> ResolverValue m)
-> ([ResolverEntry m] -> ObjectTypeResolver m)
-> [ResolverEntry m]
-> ResolverValue m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m
forall (m :: * -> *).
HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m
ObjectTypeResolver (HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m)
-> ([ResolverEntry m] -> HashMap FieldName (m (ResolverValue m)))
-> [ResolverEntry m]
-> ObjectTypeResolver m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ResolverEntry m] -> HashMap FieldName (m (ResolverValue m))
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList
mkUnion ::
(Monad m) =>
TypeName ->
[ResolverEntry m] ->
ResolverValue m
mkUnion :: TypeName -> [ResolverEntry m] -> ResolverValue m
mkUnion TypeName
name [ResolverEntry m]
fields =
Maybe TypeName -> ObjectTypeResolver m -> ResolverValue m
forall (m :: * -> *).
Maybe TypeName -> ObjectTypeResolver m -> ResolverValue m
ResObject
(TypeName -> Maybe TypeName
forall a. a -> Maybe a
Just TypeName
name)
ObjectTypeResolver :: forall (m :: * -> *).
HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m
ObjectTypeResolver {objectFields :: HashMap FieldName (m (ResolverValue m))
objectFields = [ResolverEntry m] -> HashMap FieldName (m (ResolverValue m))
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [ResolverEntry m]
fields}