{-# 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}