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