{- 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(..)
    , description
    , 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.
data Schema m = Schema
    (Maybe Text) -- ^ Description.
    (Out.ObjectType m) -- ^ Query.
    (Maybe (Out.ObjectType m)) -- ^ Mutation.
    (Maybe (Out.ObjectType m)) -- ^ Subscription.
    Directives -- ^ Directives
    (HashMap Full.Name (Type m)) -- ^ Types.
    -- Interface implementations (used only for faster access).
    (HashMap Full.Name [Type m])

-- | Schema description.
description :: forall m. Schema m -> Maybe Text
description :: Schema m -> Maybe Text
description (Schema Maybe Text
description' ObjectType m
_ Maybe (ObjectType m)
_ Maybe (ObjectType m)
_ Directives
_ HashMap Text (Type m)
_ HashMap Text [Type m]
_) = Maybe Text
description'

-- | Schema query type.
query :: forall m. Schema m -> Out.ObjectType m
query :: Schema m -> ObjectType m
query (Schema Maybe Text
_ ObjectType m
query' Maybe (ObjectType m)
_ Maybe (ObjectType m)
_ Directives
_ HashMap Text (Type m)
_ HashMap Text [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 Maybe Text
_ ObjectType m
_ Maybe (ObjectType m)
mutation' Maybe (ObjectType m)
_ Directives
_ HashMap Text (Type m)
_ HashMap Text [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 Maybe Text
_ ObjectType m
_ Maybe (ObjectType m)
_ Maybe (ObjectType m)
subscription' Directives
_ HashMap Text (Type m)
_ HashMap Text [Type m]
_) = Maybe (ObjectType m)
subscription'

-- | Schema directive definitions.
directives :: forall m. Schema m -> Directives
directives :: Schema m -> Directives
directives (Schema Maybe Text
_ ObjectType m
_ Maybe (ObjectType m)
_ Maybe (ObjectType m)
_ Directives
directives' HashMap Text (Type m)
_ HashMap Text [Type m]
_) = Directives
directives'

-- | Types referenced by the schema.
types :: forall m. Schema m -> HashMap Full.Name (Type m)
types :: Schema m -> HashMap Text (Type m)
types (Schema Maybe Text
_ ObjectType m
_ Maybe (ObjectType m)
_ Maybe (ObjectType m)
_ Directives
_ HashMap Text (Type m)
types' HashMap Text [Type m]
_) = HashMap Text (Type m)
types'

-- | Interface implementations.
implementations :: forall m. Schema m -> HashMap Full.Name [Type m]
implementations :: Schema m -> HashMap Text [Type m]
implementations (Schema Maybe Text
_ ObjectType m
_ Maybe (ObjectType m)
_ Maybe (ObjectType m)
_ Directives
_ HashMap Text (Type m)
_ HashMap Text [Type m]
implementations') = HashMap Text [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 Text
_ Maybe Text
_ [InterfaceType m]
interfaces HashMap Text (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 Text
_ Maybe Text
_ [InterfaceType m]
interfaces HashMap Text (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 Text
_ Maybe Text
_ [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 :: Text -> HashMap Text (Type m) -> Maybe (CompositeType m)
lookupTypeCondition Text
type' HashMap Text (Type m)
types' =
    case Text -> HashMap Text (Type m) -> Maybe (Type m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
type' HashMap Text (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 Text (Type m) -> Maybe Type
lookupInputType (Full.TypeNamed Text
name) HashMap Text (Type m)
types' =
    case Text -> HashMap Text (Type m) -> Maybe (Type m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
name HashMap Text (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 Text (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 Text (Type m) -> Maybe Type
forall (m :: * -> *). Type -> HashMap Text (Type m) -> Maybe Type
lookupInputType Type
list HashMap Text (Type m)
types'
lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed Text
nonNull)) HashMap Text (Type m)
types' =
    case Text -> HashMap Text (Type m) -> Maybe (Type m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
nonNull HashMap Text (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 Text (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 Text (Type m) -> Maybe Type
forall (m :: * -> *). Type -> HashMap Text (Type m) -> Maybe Type
lookupInputType Type
nonNull HashMap Text (Type m)
types'

lookupTypeField :: forall a. Full.Name -> Out.Type a -> Maybe (Out.Field a)
lookupTypeField :: Text -> Type a -> Maybe (Field a)
lookupTypeField Text
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
>>= Text -> CompositeType a -> Maybe (Field a)
forall (a :: * -> *). Text -> CompositeType a -> Maybe (Field a)
lookupCompositeField Text
fieldName

lookupCompositeField :: forall a
    . Full.Name
    -> CompositeType a
    -> Maybe (Out.Field a)
lookupCompositeField :: Text -> CompositeType a -> Maybe (Field a)
lookupCompositeField Text
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 Text
_ Maybe Text
_ [InterfaceType m]
_ HashMap Text (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
<$> Text -> HashMap Text (Resolver m) -> Maybe (Resolver m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
fieldName HashMap Text (Resolver m)
resolvers
    interfaceChild :: InterfaceType m -> Maybe (Field m)
interfaceChild (Out.InterfaceType Text
_ Maybe Text
_ [InterfaceType m]
_ HashMap Text (Field m)
fields) =
        Text -> HashMap Text (Field m) -> Maybe (Field m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
fieldName HashMap Text (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