{- 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
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 :: forall (m :: * -> *). 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 :: forall (m :: * -> *). 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 :: forall (m :: * -> *). 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 :: forall (m :: * -> *). 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 :: forall (m :: * -> *). 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 :: forall (m :: * -> *). 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 :: forall (m :: * -> *). 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
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
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 :: forall (m :: * -> *). CompositeType m -> ObjectType m -> Bool
doesFragmentTypeApply (CompositeObjectType ObjectType m
fragmentType) ObjectType m
objectType =
    ObjectType m
fragmentType forall a. Eq a => a -> a -> Bool
== ObjectType m
objectType
doesFragmentTypeApply (CompositeInterfaceType InterfaceType m
fragmentType) ObjectType m
objectType =
    forall (m :: * -> *). ObjectType m -> AbstractType m -> Bool
instanceOf ObjectType m
objectType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). InterfaceType m -> AbstractType m
AbstractInterfaceType InterfaceType m
fragmentType
doesFragmentTypeApply (CompositeUnionType UnionType m
fragmentType) ObjectType m
objectType =
    forall (m :: * -> *). ObjectType m -> AbstractType m -> Bool
instanceOf ObjectType m
objectType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). UnionType m -> AbstractType m
AbstractUnionType UnionType m
fragmentType

instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool
instanceOf :: forall (m :: * -> *). 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 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
|| forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr InterfaceType m -> Bool -> Bool
go (InterfaceType m
interfaceType 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 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 forall a. Eq a => a -> a -> Bool
== ObjectType m
unionMemberType

lookupTypeCondition :: forall m
    . Full.Name
    -> HashMap Full.Name (Type m)
    -> Maybe (CompositeType m)
lookupTypeCondition :: forall (m :: * -> *).
Text -> HashMap Text (Type m) -> Maybe (CompositeType m)
lookupTypeCondition Text
type' HashMap Text (Type m)
types' =
    case 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) ->
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). ObjectType m -> CompositeType m
CompositeObjectType ObjectType m
objectType
        Just (UnionType UnionType m
unionType) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). UnionType m -> CompositeType m
CompositeUnionType UnionType m
unionType
        Just (InterfaceType InterfaceType m
interfaceType) ->
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). InterfaceType m -> CompositeType m
CompositeInterfaceType InterfaceType m
interfaceType
        Maybe (Type m)
_ -> forall a. Maybe a
Nothing

lookupInputType :: Full.Type -> HashMap Full.Name (Type m) -> Maybe In.Type
lookupInputType :: forall (m :: * -> *). Type -> HashMap Text (Type m) -> Maybe Type
lookupInputType (Full.TypeNamed Text
name) HashMap Text (Type m)
types' =
    case 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) ->
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ScalarType -> Type
In.NamedScalarType ScalarType
scalarType
        Just (EnumType EnumType
enumType) ->
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ EnumType -> Type
In.NamedEnumType EnumType
enumType
        Just (InputObjectType InputObjectType
objectType) ->
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ InputObjectType -> Type
In.NamedInputObjectType InputObjectType
objectType
        Maybe (Type m)
_ -> forall a. Maybe a
Nothing
lookupInputType (Full.TypeList Type
list) HashMap Text (Type m)
types'
    = Type -> Type
In.ListType
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 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) ->
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ScalarType -> Type
In.NonNullScalarType ScalarType
scalarType
        Just (EnumType EnumType
enumType) ->
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ EnumType -> Type
In.NonNullEnumType EnumType
enumType
        Just (InputObjectType InputObjectType
objectType) ->
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ InputObjectType -> Type
In.NonNullInputObjectType InputObjectType
objectType
        Maybe (Type m)
_ -> forall a. Maybe a
Nothing
lookupInputType (Full.TypeNonNull (Full.NonNullTypeList Type
nonNull)) HashMap Text (Type m)
types'
    = Type -> Type
In.NonNullListType
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall (a :: * -> *). Text -> Type a -> Maybe (Field a)
lookupTypeField Text
fieldName Type a
outputType =
    forall (a :: * -> *). Type a -> Maybe (CompositeType a)
outToComposite Type a
outputType forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (a :: * -> *). Text -> CompositeType a -> Maybe (Field a)
lookupCompositeField Text
fieldName

lookupCompositeField :: forall a
    . Full.Name
    -> CompositeType a
    -> Maybe (Out.Field a)
lookupCompositeField :: forall (a :: * -> *). Text -> CompositeType a -> Maybe (Field a)
lookupCompositeField Text
fieldName = \case
    CompositeObjectType ObjectType a
objectType -> forall {m :: * -> *}. ObjectType m -> Maybe (Field m)
objectChild ObjectType a
objectType
    CompositeInterfaceType InterfaceType a
interfaceType -> forall {m :: * -> *}. InterfaceType m -> Maybe (Field m)
interfaceChild InterfaceType a
interfaceType
    CompositeType 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) =
        forall {m :: * -> *}. Resolver m -> Field m
resolverType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) =
        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 :: forall (a :: * -> *). Type a -> Maybe (CompositeType a)
outToComposite = \case
    Out.ObjectBaseType ObjectType a
objectType -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). ObjectType m -> CompositeType m
CompositeObjectType ObjectType a
objectType
    Out.InterfaceBaseType InterfaceType a
interfaceType ->
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). InterfaceType m -> CompositeType m
CompositeInterfaceType InterfaceType a
interfaceType
    Out.UnionBaseType UnionType a
unionType -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). UnionType m -> CompositeType m
CompositeUnionType UnionType a
unionType
    Out.ListBaseType Type a
listType -> forall (a :: * -> *). Type a -> Maybe (CompositeType a)
outToComposite Type a
listType
    Type a
_ -> forall a. Maybe a
Nothing