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