{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# 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,
NamedResolverFun,
buildBatches,
Cache,
CacheKey (..),
BatchEntry (..),
LocalCache,
dumpCache,
useCached,
)
where
import Control.Monad.Except (MonadError (throwError))
import Data.ByteString.Lazy.Char8 (unpack)
import qualified Data.HashMap.Lazy as HM
import Data.Morpheus.Core (RenderGQL, render)
import Data.Morpheus.Internal.Ext (Merge (..))
import Data.Morpheus.Internal.Utils (KeyOf (keyOf))
import Data.Morpheus.Types.Internal.AST
( FieldName,
GQLError,
ScalarValue (..),
SelectionContent,
TypeName,
VALID,
ValidValue,
internal,
)
import GHC.Show (Show (show))
import Relude hiding (show)
type LocalCache = HashMap CacheKey ValidValue
useCached :: (Eq k, Hashable k, MonadError GQLError f) => HashMap k a -> k -> f a
useCached :: forall k (f :: * -> *) a.
(Eq k, Hashable k, MonadError GQLError f) =>
HashMap k a -> k -> f a
useCached HashMap k a
mp k
v = case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup k
v HashMap k a
mp of
Just a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
Maybe a
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"TODO:")
dumpCache :: Bool -> (LocalCache, ResolverMap m) -> (LocalCache, ResolverMap m)
dumpCache :: forall (m :: * -> *).
Bool -> (LocalCache, ResolverMap m) -> (LocalCache, ResolverMap m)
dumpCache Bool
enabled (LocalCache, ResolverMap m)
xs
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a b. (a, b) -> a
fst (LocalCache, ResolverMap m)
xs) Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
enabled = (LocalCache, ResolverMap m)
xs
| Bool
otherwise = forall a. String -> a -> a
trace (String
"\nCACHE:\n" forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. (Show a, RenderGQL a) => (a, a) -> String
printKeyValue forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
HM.toList forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (LocalCache, ResolverMap m)
xs) forall a. Semigroup a => a -> a -> a
<> String
"\n") (LocalCache, ResolverMap m)
xs
where
printKeyValue :: (a, a) -> String
printKeyValue (a
key, a
v) = String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
key forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> ByteString -> String
unpack (forall a. RenderGQL a => a -> ByteString
render a
v)
printSel :: RenderGQL a => a -> [Char]
printSel :: forall a. RenderGQL a => a -> String
printSel a
sel = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
replace forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
ignoreSpaces forall a b. (a -> b) -> a -> b
$ ByteString -> String
unpack (forall a. RenderGQL a => a -> ByteString
render a
sel)
where
ignoreSpaces :: Char -> Bool
ignoreSpaces Char
x = Char
x forall a. Eq a => a -> a -> Bool
/= Char
' '
replace :: Char -> Char
replace Char
'\n' = Char
' '
replace Char
x = Char
x
data BatchEntry = BatchEntry
{ BatchEntry -> SelectionContent VALID
batchedSelection :: SelectionContent VALID,
BatchEntry -> TypeName
batchedType :: TypeName,
BatchEntry -> [ValidValue]
batchedArguments :: [ValidValue]
}
instance Show BatchEntry where
show :: BatchEntry -> String
show (BatchEntry SelectionContent VALID
sel TypeName
typename [ValidValue]
dep) = forall a. RenderGQL a => a -> String
printSel SelectionContent VALID
sel forall a. Semigroup a => a -> a -> a
<> String
":" forall a. Semigroup a => a -> a -> a
<> forall a. ToString a => a -> String
toString TypeName
typename forall a. Semigroup a => a -> a -> a
<> String
":" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> String
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RenderGQL a => a -> ByteString
render) [ValidValue]
dep)
data CacheKey = CacheKey
{ CacheKey -> SelectionContent VALID
cachedSel :: SelectionContent VALID,
CacheKey -> TypeName
cachedTypeName :: TypeName,
CacheKey -> ValidValue
cachedArg :: ValidValue
}
deriving (CacheKey -> CacheKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CacheKey -> CacheKey -> Bool
$c/= :: CacheKey -> CacheKey -> Bool
== :: CacheKey -> CacheKey -> Bool
$c== :: CacheKey -> CacheKey -> Bool
Eq, forall x. Rep CacheKey x -> CacheKey
forall x. CacheKey -> Rep CacheKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CacheKey x -> CacheKey
$cfrom :: forall x. CacheKey -> Rep CacheKey x
Generic)
instance Show CacheKey where
show :: CacheKey -> String
show (CacheKey SelectionContent VALID
sel TypeName
typename ValidValue
dep) = forall a. RenderGQL a => a -> String
printSel SelectionContent VALID
sel forall a. Semigroup a => a -> a -> a
<> String
":" forall a. Semigroup a => a -> a -> a
<> forall a. ToString a => a -> String
toString TypeName
typename forall a. Semigroup a => a -> a -> a
<> String
":" forall a. Semigroup a => a -> a -> a
<> ByteString -> String
unpack (forall a. RenderGQL a => a -> ByteString
render ValidValue
dep)
instance Hashable CacheKey where
hashWithSalt :: Int -> CacheKey -> Int
hashWithSalt Int
s (CacheKey SelectionContent VALID
sel TypeName
tyName ValidValue
arg) = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (SelectionContent VALID
sel, TypeName
tyName, forall a. RenderGQL a => a -> ByteString
render ValidValue
arg)
type Cache m = HashMap CacheKey (NamedResolverResult m)
type ResolverMap (m :: Type -> Type) = HashMap TypeName (NamedResolver m)
type NamedResolverArg = [ValidValue]
type NamedResolverFun m = NamedResolverArg -> m [NamedResolverResult m]
data NamedResolver (m :: Type -> Type) = NamedResolver
{ forall (m :: * -> *). NamedResolver m -> TypeName
resolverName :: TypeName,
forall (m :: * -> *). NamedResolver m -> NamedResolverFun m
resolverFun :: NamedResolverFun m
}
instance Show (NamedResolver m) where
show :: NamedResolver m -> String
show NamedResolver {TypeName
NamedResolverFun m
resolverFun :: NamedResolverFun m
resolverName :: TypeName
resolverFun :: forall (m :: * -> *). NamedResolver m -> NamedResolverFun m
resolverName :: forall (m :: * -> *). NamedResolver m -> TypeName
..} =
String
"NamedResolver { name = " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TypeName
resolverName forall a. Semigroup a => a -> a -> a
<> String
" }"
newtype ObjectTypeResolver m = ObjectTypeResolver
{ forall (m :: * -> *).
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 :: NamedResolverArg
}
deriving (Int -> NamedResolverRef -> ShowS
[NamedResolverRef] -> ShowS
NamedResolverRef -> String
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)
uniq :: (Eq a, Hashable a) => [a] -> [a]
uniq :: forall a. (Eq a, Hashable a) => [a] -> [a]
uniq = forall k v. HashMap k v -> [k]
HM.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (,Bool
True)
buildBatches :: [(SelectionContent VALID, NamedResolverRef)] -> [BatchEntry]
buildBatches :: [(SelectionContent VALID, NamedResolverRef)] -> [BatchEntry]
buildBatches [(SelectionContent VALID, NamedResolverRef)]
inputs =
let entityTypes :: [(SelectionContent VALID, TypeName)]
entityTypes = forall a. (Eq a, Hashable a) => [a] -> [a]
uniq forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second NamedResolverRef -> TypeName
resolverTypeName) [(SelectionContent VALID, NamedResolverRef)]
inputs
in forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([(SelectionContent VALID, NamedResolverRef)]
-> (SelectionContent VALID, TypeName) -> Maybe BatchEntry
selectByEntity [(SelectionContent VALID, NamedResolverRef)]
inputs) [(SelectionContent VALID, TypeName)]
entityTypes
selectByEntity :: [(SelectionContent VALID, NamedResolverRef)] -> (SelectionContent VALID, TypeName) -> Maybe BatchEntry
selectByEntity :: [(SelectionContent VALID, NamedResolverRef)]
-> (SelectionContent VALID, TypeName) -> Maybe BatchEntry
selectByEntity [(SelectionContent VALID, NamedResolverRef)]
inputs (SelectionContent VALID
tSel, TypeName
tName) = case forall a. (a -> Bool) -> [a] -> [a]
filter (SelectionContent VALID, NamedResolverRef) -> Bool
areEq [(SelectionContent VALID, NamedResolverRef)]
inputs of
[] -> forall a. Maybe a
Nothing
[(SelectionContent VALID, NamedResolverRef)]
xs -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SelectionContent VALID -> TypeName -> [ValidValue] -> BatchEntry
BatchEntry SelectionContent VALID
tSel TypeName
tName (forall a. (Eq a, Hashable a) => [a] -> [a]
uniq forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (NamedResolverRef -> [ValidValue]
resolverArgument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(SelectionContent VALID, NamedResolverRef)]
xs)
where
areEq :: (SelectionContent VALID, NamedResolverRef) -> Bool
areEq (SelectionContent VALID
sel, NamedResolverRef
v) = SelectionContent VALID
sel forall a. Eq a => a -> a -> Bool
== SelectionContent VALID
tSel Bool -> Bool -> Bool
&& TypeName
tName forall a. Eq a => a -> a -> Bool
== NamedResolverRef -> TypeName
resolverTypeName NamedResolverRef
v
data NamedResolverResult (m :: Type -> Type)
= NamedObjectResolver (ObjectTypeResolver m)
| NamedUnionResolver NamedResolverRef
| NamedEnumResolver TypeName
| NamedNullResolver
instance KeyOf TypeName (NamedResolver m) where
keyOf :: NamedResolver m -> TypeName
keyOf = forall (m :: * -> *). NamedResolver m -> TypeName
resolverName
instance Show (NamedResolverResult m) where
show :: NamedResolverResult m -> String
show NamedObjectResolver {} = String
"NamedObjectResolver"
show NamedUnionResolver {} = String
"NamedUnionResolver"
show NamedEnumResolver {} = String
"NamedEnumResolver"
show NamedNullResolver {} = String
"NamedNullResolver"
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 :: Monad f =>
ObjectTypeResolver m
-> ObjectTypeResolver m -> f (ObjectTypeResolver m)
merge (ObjectTypeResolver HashMap FieldName (m (ResolverValue m))
x) (ObjectTypeResolver HashMap FieldName (m (ResolverValue m))
y) =
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 k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HM.unionWith 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 = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m b
b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry 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
ResNull = String
"ResNull"
show (ResScalar ScalarValue
x) = String
"ResScalar:" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ScalarValue
x
show (ResList [ResolverValue m]
xs) = String
"ResList:" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [ResolverValue m]
xs
show (ResEnum TypeName
name) = String
"ResEnum:" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TypeName
name
show (ResObject Maybe TypeName
name ObjectTypeResolver m
_) = String
"ResObject:" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Maybe TypeName
name
show ResRef {} = String
"ResRef {}"
show ResLazy {} = String
"ResLazy {}"
instance IsString (ResolverValue m) where
fromString :: String -> ResolverValue m
fromString = forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString
instance
( Monad f,
MonadError GQLError f,
Merge f (ObjectTypeResolver m)
) =>
Merge f (ResolverValue m)
where
merge :: Monad f =>
ResolverValue m -> ResolverValue m -> f (ResolverValue m)
merge ResolverValue m
ResNull ResolverValue m
ResNull = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *). ResolverValue m
ResNull
merge ResScalar {} x :: ResolverValue m
x@ResScalar {} = forall (f :: * -> *) a. Applicative f => a -> f a
pure ResolverValue m
x
merge ResEnum {} x :: ResolverValue m
x@ResEnum {} = 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) = forall (m :: * -> *).
Maybe TypeName -> ObjectTypeResolver m -> ResolverValue m
ResObject Maybe TypeName
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge ObjectTypeResolver m
x ObjectTypeResolver m
y
merge ResolverValue m
_ 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 :: forall (m :: * -> *). Text -> ResolverValue m
mkString = forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ScalarValue
String
mkFloat :: Double -> ResolverValue m
mkFloat :: forall (m :: * -> *). Double -> ResolverValue m
mkFloat = forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> ScalarValue
Float
mkInt :: Int -> ResolverValue m
mkInt :: forall (m :: * -> *). Int -> ResolverValue m
mkInt = forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ScalarValue
Int
mkBoolean :: Bool -> ResolverValue m
mkBoolean :: forall (m :: * -> *). Bool -> ResolverValue m
mkBoolean = forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ScalarValue
Boolean
mkList :: [ResolverValue m] -> ResolverValue m
mkList :: forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
mkList = forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
ResList
mkNull :: ResolverValue m
mkNull :: forall (m :: * -> *). ResolverValue m
mkNull = forall (m :: * -> *). ResolverValue m
ResNull
mkEnum :: TypeName -> ResolverValue m
mkEnum :: forall (m :: * -> *). TypeName -> ResolverValue m
mkEnum = forall (m :: * -> *). TypeName -> ResolverValue m
ResEnum
mkObject ::
TypeName ->
[ResolverEntry m] ->
ResolverValue m
mkObject :: forall (m :: * -> *).
TypeName -> [ResolverEntry m] -> ResolverValue m
mkObject TypeName
name = forall (m :: * -> *).
Maybe TypeName -> [ResolverEntry m] -> ResolverValue m
mkObjectMaybe (forall a. a -> Maybe a
Just TypeName
name)
mkObjectMaybe ::
Maybe TypeName ->
[ResolverEntry m] ->
ResolverValue m
mkObjectMaybe :: forall (m :: * -> *).
Maybe TypeName -> [ResolverEntry m] -> ResolverValue m
mkObjectMaybe Maybe TypeName
name = forall (m :: * -> *).
Maybe TypeName -> ObjectTypeResolver m -> ResolverValue m
ResObject Maybe TypeName
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m
ObjectTypeResolver forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList
mkUnion ::
(Monad m) =>
TypeName ->
[ResolverEntry m] ->
ResolverValue m
mkUnion :: forall (m :: * -> *).
Monad m =>
TypeName -> [ResolverEntry m] -> ResolverValue m
mkUnion TypeName
name [ResolverEntry m]
fields =
forall (m :: * -> *).
Maybe TypeName -> ObjectTypeResolver m -> ResolverValue m
ResObject
(forall a. a -> Maybe a
Just TypeName
name)
ObjectTypeResolver {objectFields :: HashMap FieldName (m (ResolverValue m))
objectFields = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [ResolverEntry m]
fields}