{- This Source Code Form is subject to the terms of the Mozilla Public License,
   v. 2.0. If a copy of the MPL was not distributed with this file, You can
   obtain one at https://mozilla.org/MPL/2.0/. -}

{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

-- | Output types and values, monad transformer stack used by the @GraphQL@
-- resolvers.
--
-- This module is intended to be imported qualified, to avoid name clashes
-- with 'Language.GraphQL.Type.In'.
module Language.GraphQL.Type.Out
    ( Context(..)
    , Field(..)
    , InterfaceType(..)
    , ObjectType(..)
    , Resolve
    , Subscribe
    , Resolver(..)
    , SourceEventStream
    , Type(..)
    , UnionType(..)
    , argument
    , isNonNullType
    , pattern EnumBaseType
    , pattern InterfaceBaseType
    , pattern ListBaseType
    , pattern ObjectBaseType
    , pattern ScalarBaseType
    , pattern UnionBaseType
    ) where

import Conduit
import Control.Monad.Trans.Reader (ReaderT, asks)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Language.GraphQL.AST (Name)
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.In as In

-- | Object type definition.
--
-- Almost all of the GraphQL types you define will be object types. Object
-- types have a name, but most importantly describe their fields.
data ObjectType m = ObjectType
    Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m))

instance forall a. Eq (ObjectType a) where
    (ObjectType this :: Name
this _ _ _) == :: ObjectType a -> ObjectType a -> Bool
== (ObjectType that :: Name
that _ _ _) = Name
this Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
that

-- | Interface Type Definition.
--
-- When a field can return one of a heterogeneous set of types, a Interface type
-- is used to describe what types are possible, and what fields are in common
-- across all types.
data InterfaceType m = InterfaceType
    Name (Maybe Text) [InterfaceType m] (HashMap Name (Field m))

instance forall a. Eq (InterfaceType a) where
    (InterfaceType this :: Name
this _ _ _) == :: InterfaceType a -> InterfaceType a -> Bool
== (InterfaceType that :: Name
that _ _ _) = Name
this Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
that

-- | Union Type Definition.
--
-- When a field can return one of a heterogeneous set of types, a Union type is
-- used to describe what types are possible.
data UnionType m = UnionType Name (Maybe Text) [ObjectType m]

instance forall a. Eq (UnionType a) where
    (UnionType this :: Name
this _ _) == :: UnionType a -> UnionType a -> Bool
== (UnionType that :: Name
that _ _) = Name
this Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
that

-- | Output object field definition.
data Field m = Field
    (Maybe Text) -- ^ Description.
    (Type m) -- ^ Field type.
    In.Arguments -- ^ Arguments.

-- | These types may be used as output types as the result of fields.
--
-- GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
-- type can wrap other wrapping or named types. Wrapping types are lists and
-- Non-Null types (named types are nullable by default).
data Type m
    = NamedScalarType ScalarType
    | NamedEnumType EnumType
    | NamedObjectType (ObjectType m)
    | NamedInterfaceType (InterfaceType m)
    | NamedUnionType (UnionType m)
    | ListType (Type m)
    | NonNullScalarType ScalarType
    | NonNullEnumType EnumType
    | NonNullObjectType (ObjectType m)
    | NonNullInterfaceType (InterfaceType m)
    | NonNullUnionType (UnionType m)
    | NonNullListType (Type m)
    deriving Type m -> Type m -> Bool
(Type m -> Type m -> Bool)
-> (Type m -> Type m -> Bool) -> Eq (Type m)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (m :: * -> *). Type m -> Type m -> Bool
/= :: Type m -> Type m -> Bool
$c/= :: forall (m :: * -> *). Type m -> Type m -> Bool
== :: Type m -> Type m -> Bool
$c== :: forall (m :: * -> *). Type m -> Type m -> Bool
Eq

-- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
pattern ScalarBaseType :: forall m. ScalarType -> Type m
pattern $mScalarBaseType :: forall r (m :: * -> *).
Type m -> (ScalarType -> r) -> (Void# -> r) -> r
ScalarBaseType scalarType <- (isScalarType -> Just scalarType)

-- | Matches either 'NamedEnumType' or 'NonNullEnumType'.
pattern EnumBaseType :: forall m. EnumType -> Type m
pattern $mEnumBaseType :: forall r (m :: * -> *).
Type m -> (EnumType -> r) -> (Void# -> r) -> r
EnumBaseType enumType <- (isEnumType -> Just enumType)

-- | Matches either 'NamedObjectType' or 'NonNullObjectType'.
pattern ObjectBaseType :: forall m. ObjectType m -> Type m
pattern $mObjectBaseType :: forall r (m :: * -> *).
Type m -> (ObjectType m -> r) -> (Void# -> r) -> r
ObjectBaseType objectType <- (isObjectType -> Just objectType)

-- | Matches either 'NamedInterfaceType' or 'NonNullInterfaceType'.
pattern InterfaceBaseType :: forall m. InterfaceType m -> Type m
pattern $mInterfaceBaseType :: forall r (m :: * -> *).
Type m -> (InterfaceType m -> r) -> (Void# -> r) -> r
InterfaceBaseType interfaceType <-
    (isInterfaceType -> Just interfaceType)

-- | Matches either 'NamedUnionType' or 'NonNullUnionType'.
pattern UnionBaseType :: forall m. UnionType m -> Type m
pattern $mUnionBaseType :: forall r (m :: * -> *).
Type m -> (UnionType m -> r) -> (Void# -> r) -> r
UnionBaseType unionType <- (isUnionType -> Just unionType)

-- | Matches either 'ListType' or 'NonNullListType'.
pattern ListBaseType :: forall m. Type m -> Type m
pattern $mListBaseType :: forall r (m :: * -> *).
Type m -> (Type m -> r) -> (Void# -> r) -> r
ListBaseType listType <- (isListType -> Just listType)

{-# COMPLETE ScalarBaseType
    , EnumBaseType
    , ObjectBaseType
    , ListBaseType
    , InterfaceBaseType
    , UnionBaseType
    #-}

isScalarType :: forall m. Type m -> Maybe ScalarType
isScalarType :: Type m -> Maybe ScalarType
isScalarType (NamedScalarType outputType :: ScalarType
outputType) = ScalarType -> Maybe ScalarType
forall a. a -> Maybe a
Just ScalarType
outputType
isScalarType (NonNullScalarType outputType :: ScalarType
outputType) = ScalarType -> Maybe ScalarType
forall a. a -> Maybe a
Just ScalarType
outputType
isScalarType _ = Maybe ScalarType
forall a. Maybe a
Nothing

isObjectType :: forall m. Type m -> Maybe (ObjectType m)
isObjectType :: Type m -> Maybe (ObjectType m)
isObjectType (NamedObjectType outputType :: ObjectType m
outputType) = ObjectType m -> Maybe (ObjectType m)
forall a. a -> Maybe a
Just ObjectType m
outputType
isObjectType (NonNullObjectType outputType :: ObjectType m
outputType) = ObjectType m -> Maybe (ObjectType m)
forall a. a -> Maybe a
Just ObjectType m
outputType
isObjectType _ = Maybe (ObjectType m)
forall a. Maybe a
Nothing

isEnumType :: forall m. Type m -> Maybe EnumType
isEnumType :: Type m -> Maybe EnumType
isEnumType (NamedEnumType outputType :: EnumType
outputType) = EnumType -> Maybe EnumType
forall a. a -> Maybe a
Just EnumType
outputType
isEnumType (NonNullEnumType outputType :: EnumType
outputType) = EnumType -> Maybe EnumType
forall a. a -> Maybe a
Just EnumType
outputType
isEnumType _ = Maybe EnumType
forall a. Maybe a
Nothing

isInterfaceType :: forall m. Type m -> Maybe (InterfaceType m)
isInterfaceType :: Type m -> Maybe (InterfaceType m)
isInterfaceType (NamedInterfaceType interfaceType :: InterfaceType m
interfaceType) = InterfaceType m -> Maybe (InterfaceType m)
forall a. a -> Maybe a
Just InterfaceType m
interfaceType
isInterfaceType (NonNullInterfaceType interfaceType :: InterfaceType m
interfaceType) = InterfaceType m -> Maybe (InterfaceType m)
forall a. a -> Maybe a
Just InterfaceType m
interfaceType
isInterfaceType _ = Maybe (InterfaceType m)
forall a. Maybe a
Nothing

isUnionType :: forall m. Type m -> Maybe (UnionType m)
isUnionType :: Type m -> Maybe (UnionType m)
isUnionType (NamedUnionType unionType :: UnionType m
unionType) = UnionType m -> Maybe (UnionType m)
forall a. a -> Maybe a
Just UnionType m
unionType
isUnionType (NonNullUnionType unionType :: UnionType m
unionType) = UnionType m -> Maybe (UnionType m)
forall a. a -> Maybe a
Just UnionType m
unionType
isUnionType _ = Maybe (UnionType m)
forall a. Maybe a
Nothing

isListType :: forall m. Type m -> Maybe (Type m)
isListType :: Type m -> Maybe (Type m)
isListType (ListType outputType :: Type m
outputType) = Type m -> Maybe (Type m)
forall a. a -> Maybe a
Just Type m
outputType
isListType (NonNullListType outputType :: Type m
outputType) = Type m -> Maybe (Type m)
forall a. a -> Maybe a
Just Type m
outputType
isListType _ = Maybe (Type m)
forall a. Maybe a
Nothing

-- | Checks whether the given output type is a non-null type.
isNonNullType :: forall m. Type m -> Bool
isNonNullType :: Type m -> Bool
isNonNullType (NonNullScalarType _) = Bool
True
isNonNullType (NonNullEnumType _) = Bool
True
isNonNullType (NonNullObjectType _) = Bool
True
isNonNullType (NonNullInterfaceType _) = Bool
True
isNonNullType (NonNullUnionType _) = Bool
True
isNonNullType (NonNullListType _) = Bool
True
isNonNullType _ = Bool
False

-- | Resolution context holds resolver arguments and the root value.
data Context = Context
    { Context -> Arguments
arguments :: Arguments
    , Context -> Value
values :: Value
    }

-- | Monad transformer stack used by the resolvers for determining the resolved
-- value of a field.
type Resolve m = ReaderT Context m Value

-- | Monad transformer stack used by the resolvers for determining the resolved
-- event stream of a subscription field.
type Subscribe m = ReaderT Context m (SourceEventStream m)

-- | A source stream represents the sequence of events, each of which will
-- trigger a GraphQL execution corresponding to that event.
type SourceEventStream m = ConduitT () Value m ()

-- | 'Resolver' associates some function(s) with each 'Field'. 'ValueResolver'
-- resolves a 'Field' into a 'Value'. 'EventStreamResolver' resolves
-- additionally a 'Field' into a 'SourceEventStream' if it is the field of a
-- root subscription type.
--
-- The resolvers aren't part of the 'Field' itself because not all fields
-- have resolvers (interface fields don't have an implementation).
data Resolver m
    = ValueResolver (Field m) (Resolve m)
    | EventStreamResolver (Field m) (Resolve m) (Subscribe m)

-- | Retrieves an argument by its name. If the argument with this name couldn't
-- be found, returns 'Null' (i.e. the argument is assumed to
-- be optional then).
argument :: Monad m => Name -> Resolve m
argument :: Name -> Resolve m
argument argumentName :: Name
argumentName = do
    Maybe Value
argumentValue <- (Context -> Maybe Value) -> ReaderT Context m (Maybe Value)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ((Context -> Maybe Value) -> ReaderT Context m (Maybe Value))
-> (Context -> Maybe Value) -> ReaderT Context m (Maybe Value)
forall a b. (a -> b) -> a -> b
$ Arguments -> Maybe Value
lookupArgument (Arguments -> Maybe Value)
-> (Context -> Arguments) -> Context -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Arguments
arguments
    Value -> Resolve m
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Resolve m) -> Value -> Resolve m
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null Maybe Value
argumentValue
  where
    lookupArgument :: Arguments -> Maybe Value
lookupArgument (Arguments argumentMap :: HashMap Name Value
argumentMap) =
        Name -> HashMap Name Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
argumentName HashMap Name Value
argumentMap