{- 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 qualified Data.Text as 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 Name
this Maybe Name
_ [InterfaceType a]
_ HashMap Name (Resolver a)
_) == :: ObjectType a -> ObjectType a -> Bool
== (ObjectType Name
that Maybe Name
_ [InterfaceType a]
_ HashMap Name (Resolver a)
_) = Name
this Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
that

instance forall a. Show (ObjectType a) where
    show :: ObjectType a -> String
show (ObjectType Name
typeName Maybe Name
_ [InterfaceType a]
_ HashMap Name (Resolver a)
_) = Name -> String
Text.unpack Name
typeName

-- | 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 Name
this Maybe Name
_ [InterfaceType a]
_ HashMap Name (Field a)
_) == :: InterfaceType a -> InterfaceType a -> Bool
== (InterfaceType Name
that Maybe Name
_ [InterfaceType a]
_ HashMap Name (Field a)
_) = Name
this Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
that

instance forall a. Show (InterfaceType a) where
    show :: InterfaceType a -> String
show (InterfaceType Name
typeName Maybe Name
_ [InterfaceType a]
_ HashMap Name (Field a)
_) = Name -> String
Text.unpack Name
typeName

-- | 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 Name
this Maybe Name
_ [ObjectType a]
_) == :: UnionType a -> UnionType a -> Bool
== (UnionType Name
that Maybe Name
_ [ObjectType a]
_) = Name
this Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
that

instance forall a. Show (UnionType a) where
    show :: UnionType a -> String
show (UnionType Name
typeName Maybe Name
_ [ObjectType a]
_) = Name -> String
Text.unpack Name
typeName

-- | 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

instance forall a. Show (Type a) where
    show :: Type a -> String
show (NamedScalarType ScalarType
scalarType) = ScalarType -> String
forall a. Show a => a -> String
show ScalarType
scalarType
    show (NamedEnumType EnumType
enumType) = EnumType -> String
forall a. Show a => a -> String
show EnumType
enumType
    show (NamedObjectType ObjectType a
inputObjectType) = ObjectType a -> String
forall a. Show a => a -> String
show ObjectType a
inputObjectType
    show (NamedInterfaceType InterfaceType a
interfaceType) = InterfaceType a -> String
forall a. Show a => a -> String
show InterfaceType a
interfaceType
    show (NamedUnionType UnionType a
unionType) = UnionType a -> String
forall a. Show a => a -> String
show UnionType a
unionType
    show (ListType Type a
baseType) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"[", Type a -> String
forall a. Show a => a -> String
show Type a
baseType, String
"]"]
    show (NonNullScalarType ScalarType
scalarType) = Char
'!' Char -> ShowS
forall a. a -> [a] -> [a]
: ScalarType -> String
forall a. Show a => a -> String
show ScalarType
scalarType
    show (NonNullEnumType EnumType
enumType) = Char
'!' Char -> ShowS
forall a. a -> [a] -> [a]
: EnumType -> String
forall a. Show a => a -> String
show EnumType
enumType
    show (NonNullObjectType ObjectType a
inputObjectType) = Char
'!' Char -> ShowS
forall a. a -> [a] -> [a]
: ObjectType a -> String
forall a. Show a => a -> String
show ObjectType a
inputObjectType
    show (NonNullInterfaceType InterfaceType a
interfaceType) = Char
'!' Char -> ShowS
forall a. a -> [a] -> [a]
: InterfaceType a -> String
forall a. Show a => a -> String
show InterfaceType a
interfaceType
    show (NonNullUnionType UnionType a
unionType) = Char
'!' Char -> ShowS
forall a. a -> [a] -> [a]
: UnionType a -> String
forall a. Show a => a -> String
show UnionType a
unionType
    show (NonNullListType Type a
baseType) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"![", Type a -> String
forall a. Show a => a -> String
show Type a
baseType, String
"]"]

-- | 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 ScalarType
outputType) = ScalarType -> Maybe ScalarType
forall a. a -> Maybe a
Just ScalarType
outputType
isScalarType (NonNullScalarType ScalarType
outputType) = ScalarType -> Maybe ScalarType
forall a. a -> Maybe a
Just ScalarType
outputType
isScalarType Type m
_ = Maybe ScalarType
forall a. Maybe a
Nothing

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

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

isInterfaceType :: forall m. Type m -> Maybe (InterfaceType m)
isInterfaceType :: Type m -> Maybe (InterfaceType m)
isInterfaceType (NamedInterfaceType InterfaceType m
interfaceType) = InterfaceType m -> Maybe (InterfaceType m)
forall a. a -> Maybe a
Just InterfaceType m
interfaceType
isInterfaceType (NonNullInterfaceType InterfaceType m
interfaceType) = InterfaceType m -> Maybe (InterfaceType m)
forall a. a -> Maybe a
Just InterfaceType m
interfaceType
isInterfaceType Type m
_ = 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 m
unionType) = UnionType m -> Maybe (UnionType m)
forall a. a -> Maybe a
Just UnionType m
unionType
isUnionType (NonNullUnionType UnionType m
unionType) = UnionType m -> Maybe (UnionType m)
forall a. a -> Maybe a
Just UnionType m
unionType
isUnionType Type m
_ = Maybe (UnionType m)
forall a. Maybe a
Nothing

isListType :: forall m. Type m -> Maybe (Type m)
isListType :: Type m -> Maybe (Type m)
isListType (ListType Type m
outputType) = Type m -> Maybe (Type m)
forall a. a -> Maybe a
Just Type m
outputType
isListType (NonNullListType Type m
outputType) = Type m -> Maybe (Type m)
forall a. a -> Maybe a
Just Type m
outputType
isListType Type m
_ = 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 ScalarType
_) = Bool
True
isNonNullType (NonNullEnumType EnumType
_) = Bool
True
isNonNullType (NonNullObjectType ObjectType m
_) = Bool
True
isNonNullType (NonNullInterfaceType InterfaceType m
_) = Bool
True
isNonNullType (NonNullUnionType UnionType m
_) = Bool
True
isNonNullType (NonNullListType Type m
_) = Bool
True
isNonNullType Type m
_ = 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 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 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