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

module Language.GraphQL.Type.Internal
    ( AbstractType(..)
    , CompositeType(..)
    , Directive(..)
    , Directives
    , Schema(..)
    , Type(..)
    , directives
    , doesFragmentTypeApply
    , instanceOf
    , lookupInputType
    , lookupTypeCondition
    , lookupTypeField
    , mutation
    , subscription
    , query
    , types
    ) where

import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import qualified Language.GraphQL.AST as Full
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out

-- | These are all of the possible kinds of types.
data Type m
    = ScalarType Definition.ScalarType
    | EnumType Definition.EnumType
    | ObjectType (Out.ObjectType m)
    | InputObjectType In.InputObjectType
    | InterfaceType (Out.InterfaceType m)
    | UnionType (Out.UnionType 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

-- | Directive definition.
data Directive = Directive (Maybe Text) [DirectiveLocation] In.Arguments

-- | Directive definitions.
type Directives = HashMap Full.Name Directive

-- | A Schema is created by supplying the root types of each type of operation,
--   query and mutation (optional). A schema definition is then supplied to the
--   validator and executor.
--
--   __Note:__ When the schema is constructed, by default only the types that
--   are reachable by traversing the root types are included, other types must
--   be explicitly referenced.
data Schema m = Schema
    (Out.ObjectType m)
    (Maybe (Out.ObjectType m))
    (Maybe (Out.ObjectType m))
    Directives
    (HashMap Full.Name (Type m))

-- | Schema query type.
query :: forall m. Schema m -> Out.ObjectType m
query :: Schema m -> ObjectType m
query (Schema query' :: ObjectType m
query' _ _ _ _) = ObjectType m
query'

-- | Schema mutation type.
mutation :: forall m. Schema m -> Maybe (Out.ObjectType m)
mutation :: Schema m -> Maybe (ObjectType m)
mutation (Schema _ mutation' :: Maybe (ObjectType m)
mutation' _ _ _) = Maybe (ObjectType m)
mutation'

-- | Schema subscription type.
subscription :: forall m. Schema m -> Maybe (Out.ObjectType m)
subscription :: Schema m -> Maybe (ObjectType m)
subscription (Schema _ _ subscription' :: Maybe (ObjectType m)
subscription' _ _) = Maybe (ObjectType m)
subscription'

-- | Schema directive definitions.
directives :: forall m. Schema m -> Directives
directives :: Schema m -> Directives
directives (Schema _ _ _ directives' :: Directives
directives' _) = Directives
directives'

-- | Types referenced by the schema.
types :: forall m. Schema m -> HashMap Full.Name (Type m)
types :: Schema m -> HashMap Name (Type m)
types (Schema _ _ _ _ types' :: HashMap Name (Type m)
types') = HashMap Name (Type m)
types'

-- | These types may describe the parent context of a selection set.
data CompositeType m
    = CompositeUnionType (Out.UnionType m)
    | CompositeObjectType (Out.ObjectType m)
    | CompositeInterfaceType (Out.InterfaceType m)
    deriving CompositeType m -> CompositeType m -> Bool
(CompositeType m -> CompositeType m -> Bool)
-> (CompositeType m -> CompositeType m -> Bool)
-> Eq (CompositeType m)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (m :: * -> *). CompositeType m -> CompositeType m -> Bool
/= :: CompositeType m -> CompositeType m -> Bool
$c/= :: forall (m :: * -> *). CompositeType m -> CompositeType m -> Bool
== :: CompositeType m -> CompositeType m -> Bool
$c== :: forall (m :: * -> *). CompositeType m -> CompositeType m -> Bool
Eq

-- | These types may describe the parent context of a selection set.
data AbstractType m
    = AbstractUnionType (Out.UnionType m)
    | AbstractInterfaceType (Out.InterfaceType m)
    deriving AbstractType m -> AbstractType m -> Bool
(AbstractType m -> AbstractType m -> Bool)
-> (AbstractType m -> AbstractType m -> Bool)
-> Eq (AbstractType m)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (m :: * -> *). AbstractType m -> AbstractType m -> Bool
/= :: AbstractType m -> AbstractType m -> Bool
$c/= :: forall (m :: * -> *). AbstractType m -> AbstractType m -> Bool
== :: AbstractType m -> AbstractType m -> Bool
$c== :: forall (m :: * -> *). AbstractType m -> AbstractType m -> Bool
Eq

doesFragmentTypeApply :: forall m
    . CompositeType m
    -> Out.ObjectType m
    -> Bool
doesFragmentTypeApply :: CompositeType m -> ObjectType m -> Bool
doesFragmentTypeApply (CompositeObjectType fragmentType :: ObjectType m
fragmentType) objectType :: ObjectType m
objectType =
    ObjectType m
fragmentType ObjectType m -> ObjectType m -> Bool
forall a. Eq a => a -> a -> Bool
== ObjectType m
objectType
doesFragmentTypeApply (CompositeInterfaceType fragmentType :: InterfaceType m
fragmentType) objectType :: ObjectType m
objectType =
    ObjectType m -> AbstractType m -> Bool
forall (m :: * -> *). ObjectType m -> AbstractType m -> Bool
instanceOf ObjectType m
objectType (AbstractType m -> Bool) -> AbstractType m -> Bool
forall a b. (a -> b) -> a -> b
$ InterfaceType m -> AbstractType m
forall (m :: * -> *). InterfaceType m -> AbstractType m
AbstractInterfaceType InterfaceType m
fragmentType
doesFragmentTypeApply (CompositeUnionType fragmentType :: UnionType m
fragmentType) objectType :: ObjectType m
objectType =
    ObjectType m -> AbstractType m -> Bool
forall (m :: * -> *). ObjectType m -> AbstractType m -> Bool
instanceOf ObjectType m
objectType (AbstractType m -> Bool) -> AbstractType m -> Bool
forall a b. (a -> b) -> a -> b
$ UnionType m -> AbstractType m
forall (m :: * -> *). UnionType m -> AbstractType m
AbstractUnionType UnionType m
fragmentType

instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool
instanceOf :: ObjectType m -> AbstractType m -> Bool
instanceOf objectType :: ObjectType m
objectType (AbstractInterfaceType interfaceType :: InterfaceType m
interfaceType) =
    let Out.ObjectType _ _ interfaces :: [InterfaceType m]
interfaces _ = ObjectType m
objectType
     in (InterfaceType m -> Bool -> Bool)
-> Bool -> [InterfaceType m] -> Bool
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr InterfaceType m -> Bool -> Bool
go Bool
False [InterfaceType m]
interfaces
  where
    go :: InterfaceType m -> Bool -> Bool
go objectInterfaceType :: InterfaceType m
objectInterfaceType@(Out.InterfaceType _ _ interfaces :: [InterfaceType m]
interfaces _) acc :: Bool
acc =
        Bool
acc Bool -> Bool -> Bool
|| (InterfaceType m -> Bool -> Bool)
-> Bool -> [InterfaceType m] -> Bool
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr InterfaceType m -> Bool -> Bool
go (InterfaceType m
interfaceType InterfaceType m -> InterfaceType m -> Bool
forall a. Eq a => a -> a -> Bool
== InterfaceType m
objectInterfaceType) [InterfaceType m]
interfaces
instanceOf objectType :: ObjectType m
objectType (AbstractUnionType unionType :: UnionType m
unionType) =
    let Out.UnionType _ _ members :: [ObjectType m]
members = UnionType m
unionType
     in (ObjectType m -> Bool -> Bool) -> Bool -> [ObjectType m] -> Bool
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ObjectType m -> Bool -> Bool
go Bool
False [ObjectType m]
members
  where
    go :: ObjectType m -> Bool -> Bool
go unionMemberType :: ObjectType m
unionMemberType acc :: Bool
acc = Bool
acc Bool -> Bool -> Bool
|| ObjectType m
objectType ObjectType m -> ObjectType m -> Bool
forall a. Eq a => a -> a -> Bool
== ObjectType m
unionMemberType

lookupTypeCondition :: forall m
    . Full.Name
    -> HashMap Full.Name (Type m)
    -> Maybe (CompositeType m)
lookupTypeCondition :: Name -> HashMap Name (Type m) -> Maybe (CompositeType m)
lookupTypeCondition type' :: Name
type' types' :: HashMap Name (Type m)
types' =
    case Name -> HashMap Name (Type m) -> Maybe (Type m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
type' HashMap Name (Type m)
types' of
        Just (ObjectType objectType :: ObjectType m
objectType) ->
            CompositeType m -> Maybe (CompositeType m)
forall a. a -> Maybe a
Just (CompositeType m -> Maybe (CompositeType m))
-> CompositeType m -> Maybe (CompositeType m)
forall a b. (a -> b) -> a -> b
$ ObjectType m -> CompositeType m
forall (m :: * -> *). ObjectType m -> CompositeType m
CompositeObjectType ObjectType m
objectType
        Just (UnionType unionType :: UnionType m
unionType) -> CompositeType m -> Maybe (CompositeType m)
forall a. a -> Maybe a
Just (CompositeType m -> Maybe (CompositeType m))
-> CompositeType m -> Maybe (CompositeType m)
forall a b. (a -> b) -> a -> b
$ UnionType m -> CompositeType m
forall (m :: * -> *). UnionType m -> CompositeType m
CompositeUnionType UnionType m
unionType
        Just (InterfaceType interfaceType :: InterfaceType m
interfaceType) ->
            CompositeType m -> Maybe (CompositeType m)
forall a. a -> Maybe a
Just (CompositeType m -> Maybe (CompositeType m))
-> CompositeType m -> Maybe (CompositeType m)
forall a b. (a -> b) -> a -> b
$ InterfaceType m -> CompositeType m
forall (m :: * -> *). InterfaceType m -> CompositeType m
CompositeInterfaceType InterfaceType m
interfaceType
        _ -> Maybe (CompositeType m)
forall a. Maybe a
Nothing

lookupInputType :: Full.Type -> HashMap Full.Name (Type m) -> Maybe In.Type
lookupInputType :: Type -> HashMap Name (Type m) -> Maybe Type
lookupInputType (Full.TypeNamed name :: Name
name) types' :: HashMap Name (Type m)
types' =
    case Name -> HashMap Name (Type m) -> Maybe (Type m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
name HashMap Name (Type m)
types' of
        Just (ScalarType scalarType :: ScalarType
scalarType) ->
            Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ ScalarType -> Type
In.NamedScalarType ScalarType
scalarType
        Just (EnumType enumType :: EnumType
enumType) ->
            Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ EnumType -> Type
In.NamedEnumType EnumType
enumType
        Just (InputObjectType objectType :: InputObjectType
objectType) ->
            Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ InputObjectType -> Type
In.NamedInputObjectType InputObjectType
objectType
        _ -> Maybe Type
forall a. Maybe a
Nothing
lookupInputType (Full.TypeList list :: Type
list) types' :: HashMap Name (Type m)
types'
    = Type -> Type
In.ListType
    (Type -> Type) -> Maybe Type -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> HashMap Name (Type m) -> Maybe Type
forall (m :: * -> *). Type -> HashMap Name (Type m) -> Maybe Type
lookupInputType Type
list HashMap Name (Type m)
types'
lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull :: Name
nonNull)) types' :: HashMap Name (Type m)
types' =
    case Name -> HashMap Name (Type m) -> Maybe (Type m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
nonNull HashMap Name (Type m)
types' of
        Just (ScalarType scalarType :: ScalarType
scalarType) ->
            Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ ScalarType -> Type
In.NonNullScalarType ScalarType
scalarType
        Just (EnumType enumType :: EnumType
enumType) ->
            Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ EnumType -> Type
In.NonNullEnumType EnumType
enumType
        Just (InputObjectType objectType :: InputObjectType
objectType) ->
            Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ InputObjectType -> Type
In.NonNullInputObjectType InputObjectType
objectType
        _ -> Maybe Type
forall a. Maybe a
Nothing
lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull :: Type
nonNull)) types' :: HashMap Name (Type m)
types'
    = Type -> Type
In.NonNullListType
    (Type -> Type) -> Maybe Type -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> HashMap Name (Type m) -> Maybe Type
forall (m :: * -> *). Type -> HashMap Name (Type m) -> Maybe Type
lookupInputType Type
nonNull HashMap Name (Type m)
types'

lookupTypeField :: forall a. Full.Name -> Out.Type a -> Maybe (Out.Field a)
lookupTypeField :: Name -> Type a -> Maybe (Field a)
lookupTypeField fieldName :: Name
fieldName = \case
    Out.ObjectBaseType objectType :: ObjectType a
objectType ->
        ObjectType a -> Maybe (Field a)
forall (m :: * -> *). ObjectType m -> Maybe (Field m)
objectChild ObjectType a
objectType
    Out.InterfaceBaseType interfaceType :: InterfaceType a
interfaceType ->
        InterfaceType a -> Maybe (Field a)
forall (m :: * -> *). InterfaceType m -> Maybe (Field m)
interfaceChild InterfaceType a
interfaceType
    Out.ListBaseType listType :: Type a
listType -> Name -> Type a -> Maybe (Field a)
forall (a :: * -> *). Name -> Type a -> Maybe (Field a)
lookupTypeField Name
fieldName Type a
listType
    _ -> Maybe (Field a)
forall a. Maybe a
Nothing
  where
    objectChild :: ObjectType m -> Maybe (Field m)
objectChild (Out.ObjectType _ _ _ resolvers :: HashMap Name (Resolver m)
resolvers) =
        Resolver m -> Field m
forall (m :: * -> *). Resolver m -> Field m
resolverType (Resolver m -> Field m) -> Maybe (Resolver m) -> Maybe (Field m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> HashMap Name (Resolver m) -> Maybe (Resolver m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
fieldName HashMap Name (Resolver m)
resolvers
    interfaceChild :: InterfaceType m -> Maybe (Field m)
interfaceChild (Out.InterfaceType _ _ _ fields :: HashMap Name (Field m)
fields) =
        Name -> HashMap Name (Field m) -> Maybe (Field m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
fieldName HashMap Name (Field m)
fields
    resolverType :: Resolver m -> Field m
resolverType (Out.ValueResolver objectField :: Field m
objectField _) = Field m
objectField
    resolverType (Out.EventStreamResolver objectField :: Field m
objectField _ _) = Field m
objectField