{-# 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,
    NamedResolverFun,
  )
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 (IsMap (toAssoc), 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)

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
resolverName :: forall (m :: * -> *). NamedResolver m -> TypeName
resolverFun :: forall (m :: * -> *). NamedResolver m -> NamedResolverFun m
resolverName :: TypeName
resolverFun :: NamedResolverFun m
..} =
    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
  { 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 {HashMap FieldName (m (ResolverValue m))
objectFields :: forall (m :: * -> *).
ObjectTypeResolver m -> HashMap FieldName (m (ResolverValue m))
objectFields :: HashMap FieldName (m (ResolverValue m))
..} = String
"ObjectTypeResolver { " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," (((FieldName, m (ResolverValue m)) -> String)
-> [(FieldName, m (ResolverValue m))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (FieldName, m (ResolverValue m)) -> String
forall {a} {b}. Show a => (a, b) -> String
showField (HashMap FieldName (m (ResolverValue m))
-> [(FieldName, m (ResolverValue m))]
forall a. HashMap FieldName a -> [(FieldName, a)]
forall k (m :: * -> *) a. IsMap k m => m a -> [(k, a)]
toAssoc HashMap FieldName (m (ResolverValue m))
objectFields)) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" }"
    where
      showField :: (a, b) -> String
showField (a
name, b
_) = a -> String
forall a. Show a => a -> String
show a
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"ResolverValue m"

data NamedResolverRef = NamedResolverRef
  { NamedResolverRef -> TypeName
resolverTypeName :: TypeName,
    NamedResolverRef -> NamedResolverArg
resolverArgument :: NamedResolverArg
  }
  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
$cshowsPrec :: Int -> NamedResolverRef -> ShowS
showsPrec :: Int -> NamedResolverRef -> ShowS
$cshow :: NamedResolverRef -> String
show :: NamedResolverRef -> String
$cshowList :: [NamedResolverRef] -> ShowS
showList :: [NamedResolverRef] -> ShowS
Show)

data NamedResolverResult (m :: Type -> Type)
  = NamedObjectResolver (ObjectTypeResolver m)
  | NamedUnionResolver NamedResolverRef
  | NamedEnumResolver TypeName
  | NamedScalarResolver ScalarValue
  | NamedNullResolver

instance KeyOf TypeName (NamedResolver m) where
  keyOf :: NamedResolver m -> TypeName
keyOf = NamedResolver m -> TypeName
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"
  show NamedScalarResolver {} = String
"NamedScalarResolver"

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) =
    ObjectTypeResolver m -> f (ObjectTypeResolver m)
forall a. a -> f a
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 =>
(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 a b. m (a -> b) -> m a -> m 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 a b. m a -> (a -> 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
ResNull = String
"ResNull"
  show (ResScalar ScalarValue
x) = String
"ResScalar:" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ScalarValue -> String
forall a. Show a => a -> String
show ScalarValue
x
  show (ResList [ResolverValue m]
xs) = String
"ResList:" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [ResolverValue m] -> String
forall a. Show a => a -> String
show [ResolverValue m]
xs
  show (ResEnum TypeName
name) = String
"ResEnum:" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeName -> String
forall a. Show a => a -> String
show TypeName
name
  show (ResObject Maybe TypeName
name ObjectTypeResolver m
_) = String
"ResObject:" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe TypeName -> String
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 = 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 :: Monad f =>
ResolverValue m -> ResolverValue m -> f (ResolverValue m)
merge ResolverValue m
ResNull ResolverValue m
ResNull = ResolverValue m -> f (ResolverValue m)
forall a. a -> f a
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 a. a -> f a
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 a. a -> f a
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 a. GQLError -> f a
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 = 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 :: forall (m :: * -> *). 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 :: forall (m :: * -> *). 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 :: forall (m :: * -> *). 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 :: forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
mkList = [ResolverValue m] -> ResolverValue m
forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
ResList

mkNull :: ResolverValue m
mkNull :: forall (m :: * -> *). ResolverValue m
mkNull = ResolverValue m
forall (m :: * -> *). ResolverValue m
ResNull

mkEnum :: TypeName -> ResolverValue m
mkEnum :: forall (m :: * -> *). TypeName -> ResolverValue m
mkEnum = TypeName -> ResolverValue m
forall (m :: * -> *). TypeName -> ResolverValue m
ResEnum

mkObject ::
  TypeName ->
  [ResolverEntry m] ->
  ResolverValue m
mkObject :: forall (m :: * -> *).
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 :: forall (m :: * -> *).
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 :: forall (m :: * -> *).
Monad m =>
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 {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}