{- 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
    , implementations
    , instanceOf
    , lookupCompositeField
    , lookupInputType
    , lookupTypeCondition
    , lookupTypeField
    , mutation
    , outToComposite
    , 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))
    (HashMap Full.Name [Type m])

-- | Schema query type.
query :: forall m. Schema m -> Out.ObjectType m
query :: Schema m -> ObjectType m
query (Schema ObjectType m
query' Maybe (ObjectType m)
_ Maybe (ObjectType m)
_ Directives
_ HashMap Name (Type m)
_ HashMap Name [Type m]
_) = ObjectType m
query'

-- | Schema mutation type.
mutation :: forall m. Schema m -> Maybe (Out.ObjectType m)
mutation :: Schema m -> Maybe (ObjectType m)
mutation (Schema ObjectType m
_ Maybe (ObjectType m)
mutation' Maybe (ObjectType m)
_ Directives
_ HashMap Name (Type m)
_ HashMap Name [Type m]
_) = Maybe (ObjectType m)
mutation'

-- | Schema subscription type.
subscription :: forall m. Schema m -> Maybe (Out.ObjectType m)
subscription :: Schema m -> Maybe (ObjectType m)
subscription (Schema ObjectType m
_ Maybe (ObjectType m)
_ Maybe (ObjectType m)
subscription' Directives
_ HashMap Name (Type m)
_ HashMap Name [Type m]
_) = Maybe (ObjectType m)
subscription'

-- | Schema directive definitions.
directives :: forall m. Schema m -> Directives
directives :: Schema m -> Directives
directives (Schema ObjectType m
_ Maybe (ObjectType m)
_ Maybe (ObjectType m)
_ Directives
directives' HashMap Name (Type m)
_ HashMap Name [Type m]
_) = 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 ObjectType m
_ Maybe (ObjectType m)
_ Maybe (ObjectType m)
_ Directives
_ HashMap Name (Type m)
types' HashMap Name [Type m]
_) = HashMap Name (Type m)
types'

-- | Interface implementations.
implementations :: forall m. Schema m -> HashMap Full.Name [Type m]
implementations :: Schema m -> HashMap Name [Type m]
implementations (Schema ObjectType m
_ Maybe (ObjectType m)
_ Maybe (ObjectType m)
_ Directives
_ HashMap Name (Type m)
_ HashMap Name [Type m]
implementations') = HashMap Name [Type m]
implementations'

-- | 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 ObjectType m
fragmentType) ObjectType m
objectType =
    ObjectType m
fragmentType ObjectType m -> ObjectType m -> Bool
forall a. Eq a => a -> a -> Bool
== ObjectType m
objectType
doesFragmentTypeApply (CompositeInterfaceType InterfaceType m
fragmentType) 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 UnionType m
fragmentType) 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 m
objectType (AbstractInterfaceType InterfaceType m
interfaceType) =
    let Out.ObjectType Name
_ Maybe Name
_ [InterfaceType m]
interfaces HashMap Name (Resolver m)
_ = 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 Name
_ Maybe Name
_ [InterfaceType m]
interfaces HashMap Name (Field m)
_) 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 m
objectType (AbstractUnionType UnionType m
unionType) =
    let Out.UnionType Name
_ Maybe Name
_ [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 ObjectType m
unionMemberType 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 Name
type' 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 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 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 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 (Type m)
_ -> 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) 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) ->
            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) ->
            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 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 m)
_ -> Maybe Type
forall a. Maybe a
Nothing
lookupInputType (Full.TypeList Type
list) 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 Name
nonNull)) 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) ->
            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) ->
            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 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 m)
_ -> Maybe Type
forall a. Maybe a
Nothing
lookupInputType (Full.TypeNonNull (Full.NonNullTypeList Type
nonNull)) 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 Name
fieldName Type a
outputType =
    Type a -> Maybe (CompositeType a)
forall (a :: * -> *). Type a -> Maybe (CompositeType a)
outToComposite Type a
outputType Maybe (CompositeType a)
-> (CompositeType a -> Maybe (Field a)) -> Maybe (Field a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> CompositeType a -> Maybe (Field a)
forall (a :: * -> *). Name -> CompositeType a -> Maybe (Field a)
lookupCompositeField Name
fieldName

lookupCompositeField :: forall a
    . Full.Name
    -> CompositeType a
    -> Maybe (Out.Field a)
lookupCompositeField :: Name -> CompositeType a -> Maybe (Field a)
lookupCompositeField Name
fieldName = \case
    CompositeObjectType ObjectType a
objectType -> ObjectType a -> Maybe (Field a)
forall (m :: * -> *). ObjectType m -> Maybe (Field m)
objectChild ObjectType a
objectType
    CompositeInterfaceType InterfaceType a
interfaceType -> InterfaceType a -> Maybe (Field a)
forall (m :: * -> *). InterfaceType m -> Maybe (Field m)
interfaceChild InterfaceType a
interfaceType
    CompositeType a
_ -> Maybe (Field a)
forall a. Maybe a
Nothing
  where
    objectChild :: ObjectType m -> Maybe (Field m)
objectChild (Out.ObjectType Name
_ Maybe Name
_ [InterfaceType m]
_ 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 Name
_ Maybe Name
_ [InterfaceType m]
_ 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 Field m
objectField Resolve m
_) = Field m
objectField
    resolverType (Out.EventStreamResolver Field m
objectField Resolve m
_ Subscribe m
_) = Field m
objectField

outToComposite :: forall a. Out.Type a -> Maybe (CompositeType a)
outToComposite :: Type a -> Maybe (CompositeType a)
outToComposite = \case
    Out.ObjectBaseType ObjectType a
objectType -> CompositeType a -> Maybe (CompositeType a)
forall a. a -> Maybe a
Just (CompositeType a -> Maybe (CompositeType a))
-> CompositeType a -> Maybe (CompositeType a)
forall a b. (a -> b) -> a -> b
$ ObjectType a -> CompositeType a
forall (m :: * -> *). ObjectType m -> CompositeType m
CompositeObjectType ObjectType a
objectType
    Out.InterfaceBaseType InterfaceType a
interfaceType ->
        CompositeType a -> Maybe (CompositeType a)
forall a. a -> Maybe a
Just (CompositeType a -> Maybe (CompositeType a))
-> CompositeType a -> Maybe (CompositeType a)
forall a b. (a -> b) -> a -> b
$ InterfaceType a -> CompositeType a
forall (m :: * -> *). InterfaceType m -> CompositeType m
CompositeInterfaceType InterfaceType a
interfaceType
    Out.UnionBaseType UnionType a
unionType -> CompositeType a -> Maybe (CompositeType a)
forall a. a -> Maybe a
Just (CompositeType a -> Maybe (CompositeType a))
-> CompositeType a -> Maybe (CompositeType a)
forall a b. (a -> b) -> a -> b
$ UnionType a -> CompositeType a
forall (m :: * -> *). UnionType m -> CompositeType m
CompositeUnionType UnionType a
unionType
    Out.ListBaseType Type a
listType -> Type a -> Maybe (CompositeType a)
forall (a :: * -> *). Type a -> Maybe (CompositeType a)
outToComposite Type a
listType
    Type a
_ -> Maybe (CompositeType a)
forall a. Maybe a
Nothing