{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Validation.Query.Fragment
  ( validateFragments,
    castFragmentType,
    validateFragment,
    selectFragmentType,
    ValidateFragmentSelection,
    validateSpread,
  )
where

import Control.Monad.Except (throwError)
import Data.Morpheus.Error.Fragment
  ( cannotBeSpreadOnType,
  )
import Data.Morpheus.Types.Internal.AST
  ( DirectiveLocation (..),
    Fragment (..),
    FragmentName,
    Fragments,
    IMPLEMENTABLE,
    Position,
    RAW,
    Ref (..),
    Selection (..),
    SelectionSet,
    Stage,
    TypeDefinition,
    TypeName,
    UnionTag (..),
    VALID,
  )
import Data.Morpheus.Types.Internal.Validation
  ( Constraint (..),
    FragmentValidator,
    askFragments,
    askTypeDefinitions,
    constraint,
    selectKnown,
  )
import Data.Morpheus.Validation.Internal.Directive (validateDirectives)
import Relude hiding (empty)

class ValidateFragmentSelection (s :: Stage) where
  validateFragmentSelection ::
    Applicative m =>
    (Fragment RAW -> m (SelectionSet VALID)) ->
    Fragment s ->
    m (SelectionSet VALID)

instance ValidateFragmentSelection VALID where
  validateFragmentSelection :: forall (m :: * -> *).
Applicative m =>
(Fragment RAW -> m (SelectionSet VALID))
-> Fragment VALID -> m (SelectionSet VALID)
validateFragmentSelection Fragment RAW -> m (SelectionSet VALID)
_ = MergeMap 'False FieldName (Selection VALID)
-> m (MergeMap 'False FieldName (Selection VALID))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MergeMap 'False FieldName (Selection VALID)
 -> m (MergeMap 'False FieldName (Selection VALID)))
-> (Fragment VALID -> MergeMap 'False FieldName (Selection VALID))
-> Fragment VALID
-> m (MergeMap 'False FieldName (Selection VALID))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fragment VALID -> MergeMap 'False FieldName (Selection VALID)
Fragment VALID -> SelectionSet VALID
forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection

instance ValidateFragmentSelection RAW where
  validateFragmentSelection :: forall (m :: * -> *).
Applicative m =>
(Fragment RAW -> m (SelectionSet VALID))
-> Fragment RAW -> m (SelectionSet VALID)
validateFragmentSelection Fragment RAW -> m (SelectionSet VALID)
f = Fragment RAW -> m (SelectionSet VALID)
f

validateSpread ::
  ValidateFragmentSelection s =>
  (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) ->
  [TypeName] ->
  Ref FragmentName ->
  FragmentValidator s UnionTag
validateSpread :: forall (s :: Stage).
ValidateFragmentSelection s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeName] -> Ref FragmentName -> FragmentValidator s UnionTag
validateSpread Fragment RAW -> FragmentValidator s (SelectionSet VALID)
f [TypeName]
allowedTargets Ref FragmentName
ref = do
  fragment :: Fragment s
fragment@Fragment {TypeName
fragmentType :: TypeName
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentType, FragmentName
fragmentName :: FragmentName
fragmentName :: forall (stage :: Stage). Fragment stage -> FragmentName
fragmentName} <- [TypeName] -> Ref FragmentName -> FragmentValidator s (Fragment s)
forall (s :: Stage).
[TypeName] -> Ref FragmentName -> FragmentValidator s (Fragment s)
resolveSpread [TypeName]
allowedTargets Ref FragmentName
ref
  TypeName -> SelectionSet VALID -> UnionTag
UnionTag TypeName
fragmentType (MergeMap 'False FieldName (Selection VALID) -> UnionTag)
-> (MergeMap 'False FieldName (Selection VALID)
    -> MergeMap 'False FieldName (Selection VALID))
-> MergeMap 'False FieldName (Selection VALID)
-> UnionTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Selection VALID -> Selection VALID)
-> MergeMap 'False FieldName (Selection VALID)
-> MergeMap 'False FieldName (Selection VALID)
forall a b.
(a -> b)
-> MergeMap 'False FieldName a -> MergeMap 'False FieldName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Selection VALID
s -> Selection VALID
s {selectionOrigin = Just fragmentName}) (MergeMap 'False FieldName (Selection VALID) -> UnionTag)
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'False FieldName (Selection VALID))
-> FragmentValidator s UnionTag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> Fragment s -> FragmentValidator s (SelectionSet VALID)
forall (s :: Stage) (m :: * -> *).
(ValidateFragmentSelection s, Applicative m) =>
(Fragment RAW -> m (SelectionSet VALID))
-> Fragment s -> m (SelectionSet VALID)
forall (m :: * -> *).
Applicative m =>
(Fragment RAW -> m (SelectionSet VALID))
-> Fragment s -> m (SelectionSet VALID)
validateFragmentSelection Fragment RAW -> FragmentValidator s (SelectionSet VALID)
f Fragment s
fragment

validateFragment ::
  DirectiveLocation ->
  (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) ->
  [TypeName] ->
  Fragment RAW ->
  FragmentValidator s (Fragment VALID)
validateFragment :: forall (s :: Stage).
DirectiveLocation
-> (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeName]
-> Fragment RAW
-> FragmentValidator s (Fragment VALID)
validateFragment DirectiveLocation
loc Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validate [TypeName]
allowedTypes fragment :: Fragment RAW
fragment@Fragment {Position
fragmentPosition :: Position
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentPosition} =
  Maybe FragmentName
-> Position
-> [TypeName]
-> Fragment RAW
-> FragmentValidator s (Fragment RAW)
forall (s :: Stage) (s1 :: Stage).
Maybe FragmentName
-> Position
-> [TypeName]
-> Fragment s
-> FragmentValidator s1 (Fragment s)
castFragmentType Maybe FragmentName
forall a. Maybe a
Nothing Position
fragmentPosition [TypeName]
allowedTypes Fragment RAW
fragment
    FragmentValidator s (Fragment RAW)
-> (Fragment RAW
    -> Validator VALID (OperationContext VALID s) (Fragment VALID))
-> Validator VALID (OperationContext VALID s) (Fragment VALID)
forall a b.
Validator VALID (OperationContext VALID s) a
-> (a -> Validator VALID (OperationContext VALID s) b)
-> Validator VALID (OperationContext VALID s) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DirectiveLocation
-> (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> Fragment RAW
-> Validator VALID (OperationContext VALID s) (Fragment VALID)
forall (s :: Stage).
DirectiveLocation
-> (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> Fragment RAW
-> FragmentValidator s (Fragment VALID)
onlyValidateFrag DirectiveLocation
loc Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validate

validateFragments ::
  (Fragment RAW -> FragmentValidator RAW (SelectionSet VALID)) ->
  FragmentValidator RAW (Fragments VALID)
validateFragments :: (Fragment RAW -> FragmentValidator RAW (SelectionSet VALID))
-> FragmentValidator RAW (Fragments VALID)
validateFragments Fragment RAW -> FragmentValidator RAW (SelectionSet VALID)
f = Validator VALID (OperationContext VALID RAW) (Fragments RAW)
forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *).
MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m =>
m (Fragments s3)
askFragments Validator VALID (OperationContext VALID RAW) (Fragments RAW)
-> (Fragments RAW -> FragmentValidator RAW (Fragments VALID))
-> FragmentValidator RAW (Fragments VALID)
forall a b.
Validator VALID (OperationContext VALID RAW) a
-> (a -> Validator VALID (OperationContext VALID RAW) b)
-> Validator VALID (OperationContext VALID RAW) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Fragment RAW
 -> Validator VALID (OperationContext VALID RAW) (Fragment VALID))
-> Fragments RAW -> FragmentValidator RAW (Fragments VALID)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> OrdMap FragmentName a -> f (OrdMap FragmentName b)
traverse (DirectiveLocation
-> (Fragment RAW -> FragmentValidator RAW (SelectionSet VALID))
-> Fragment RAW
-> Validator VALID (OperationContext VALID RAW) (Fragment VALID)
forall (s :: Stage).
DirectiveLocation
-> (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> Fragment RAW
-> FragmentValidator s (Fragment VALID)
onlyValidateFrag DirectiveLocation
LOCATION_FRAGMENT_DEFINITION Fragment RAW -> FragmentValidator RAW (SelectionSet VALID)
f)

onlyValidateFrag ::
  DirectiveLocation ->
  (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) ->
  Fragment RAW ->
  FragmentValidator s (Fragment VALID)
onlyValidateFrag :: forall (s :: Stage).
DirectiveLocation
-> (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> Fragment RAW
-> FragmentValidator s (Fragment VALID)
onlyValidateFrag DirectiveLocation
loc Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validate f :: Fragment RAW
f@Fragment {SelectionSet RAW
Directives RAW
Position
TypeName
FragmentName
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentName :: forall (stage :: Stage). Fragment stage -> FragmentName
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentName :: FragmentName
fragmentType :: TypeName
fragmentPosition :: Position
fragmentSelection :: SelectionSet RAW
fragmentDirectives :: Directives RAW
fragmentDirectives :: forall (stage :: Stage). Fragment stage -> Directives stage
..} =
  FragmentName
-> TypeName
-> Position
-> SelectionSet VALID
-> Directives VALID
-> Fragment VALID
forall (stage :: Stage).
FragmentName
-> TypeName
-> Position
-> SelectionSet stage
-> Directives stage
-> Fragment stage
Fragment
    FragmentName
fragmentName
    TypeName
fragmentType
    Position
fragmentPosition
    (MergeMap 'False FieldName (Selection VALID)
 -> Directives VALID -> Fragment VALID)
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'False FieldName (Selection VALID))
-> Validator
     VALID
     (OperationContext VALID s)
     (Directives VALID -> Fragment VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validate Fragment RAW
f
    Validator
  VALID
  (OperationContext VALID s)
  (Directives VALID -> Fragment VALID)
-> Validator VALID (OperationContext VALID s) (Directives VALID)
-> Validator VALID (OperationContext VALID s) (Fragment VALID)
forall a b.
Validator VALID (OperationContext VALID s) (a -> b)
-> Validator VALID (OperationContext VALID s) a
-> Validator VALID (OperationContext VALID s) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DirectiveLocation
-> Directives RAW
-> Validator VALID (OperationContext VALID s) (Directives VALID)
forall ctx (schemaS :: Stage) (s :: Stage).
ArgumentsConstraints ctx schemaS s =>
DirectiveLocation
-> Directives s -> Validator schemaS ctx (Directives VALID)
validateDirectives DirectiveLocation
loc Directives RAW
fragmentDirectives

castFragmentType ::
  Maybe FragmentName ->
  Position ->
  [TypeName] ->
  Fragment s ->
  FragmentValidator s1 (Fragment s)
castFragmentType :: forall (s :: Stage) (s1 :: Stage).
Maybe FragmentName
-> Position
-> [TypeName]
-> Fragment s
-> FragmentValidator s1 (Fragment s)
castFragmentType Maybe FragmentName
key Position
position [TypeName]
typeMembers fragment :: Fragment s
fragment@Fragment {TypeName
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentType :: TypeName
fragmentType}
  | TypeName
fragmentType TypeName -> [TypeName] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TypeName]
typeMembers = Fragment s
-> Validator VALID (OperationContext VALID s1) (Fragment s)
forall a. a -> Validator VALID (OperationContext VALID s1) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Fragment s
fragment
  | Bool
otherwise = GQLError
-> Validator VALID (OperationContext VALID s1) (Fragment s)
forall a. GQLError -> Validator VALID (OperationContext VALID s1) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError
 -> Validator VALID (OperationContext VALID s1) (Fragment s))
-> GQLError
-> Validator VALID (OperationContext VALID s1) (Fragment s)
forall a b. (a -> b) -> a -> b
$ Maybe FragmentName
-> TypeName -> Position -> [TypeName] -> GQLError
cannotBeSpreadOnType Maybe FragmentName
key TypeName
fragmentType Position
position [TypeName]
typeMembers

resolveSpread :: [TypeName] -> Ref FragmentName -> FragmentValidator s (Fragment s)
resolveSpread :: forall (s :: Stage).
[TypeName] -> Ref FragmentName -> FragmentValidator s (Fragment s)
resolveSpread [TypeName]
allowedTargets ref :: Ref FragmentName
ref@Ref {FragmentName
refName :: FragmentName
refName :: forall name. Ref name -> name
refName, Position
refPosition :: Position
refPosition :: forall name. Ref name -> Position
refPosition} =
  Validator VALID (OperationContext VALID s) (Fragments s)
forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *).
MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m =>
m (Fragments s3)
askFragments
    Validator VALID (OperationContext VALID s) (Fragments s)
-> (Fragments s
    -> Validator VALID (OperationContext VALID s) (Fragment s))
-> Validator VALID (OperationContext VALID s) (Fragment s)
forall a b.
Validator VALID (OperationContext VALID s) a
-> (a -> Validator VALID (OperationContext VALID s) b)
-> Validator VALID (OperationContext VALID s) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ref FragmentName
-> Fragments s
-> Validator VALID (OperationContext VALID s) (Fragment s)
forall k (c :: * -> *) sel ctx a (s :: Stage).
(IsMap k c, Unknown sel ctx, KeyOf k sel) =>
sel -> c a -> Validator s ctx a
selectKnown Ref FragmentName
ref
    Validator VALID (OperationContext VALID s) (Fragment s)
-> (Fragment s
    -> Validator VALID (OperationContext VALID s) (Fragment s))
-> Validator VALID (OperationContext VALID s) (Fragment s)
forall a b.
Validator VALID (OperationContext VALID s) a
-> (a -> Validator VALID (OperationContext VALID s) b)
-> Validator VALID (OperationContext VALID s) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe FragmentName
-> Position
-> [TypeName]
-> Fragment s
-> Validator VALID (OperationContext VALID s) (Fragment s)
forall (s :: Stage) (s1 :: Stage).
Maybe FragmentName
-> Position
-> [TypeName]
-> Fragment s
-> FragmentValidator s1 (Fragment s)
castFragmentType (FragmentName -> Maybe FragmentName
forall a. a -> Maybe a
Just FragmentName
refName) Position
refPosition [TypeName]
allowedTargets

selectFragmentType :: Fragment RAW -> FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
selectFragmentType :: forall (s :: Stage).
Fragment RAW
-> FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
selectFragmentType fr :: Fragment RAW
fr@Fragment {TypeName
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentType :: TypeName
fragmentType, Position
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentPosition :: Position
fragmentPosition} = do
  TypeDefinition ANY VALID
typeDef <- Validator
  VALID
  (OperationContext VALID s)
  (HashMap TypeName (TypeDefinition ANY VALID))
forall (s :: Stage) ctx (m :: * -> *).
MonadReader (ValidatorContext s ctx) m =>
m (HashMap TypeName (TypeDefinition ANY s))
askTypeDefinitions Validator
  VALID
  (OperationContext VALID s)
  (HashMap TypeName (TypeDefinition ANY VALID))
-> (HashMap TypeName (TypeDefinition ANY VALID)
    -> Validator
         VALID (OperationContext VALID s) (TypeDefinition ANY VALID))
-> Validator
     VALID (OperationContext VALID s) (TypeDefinition ANY VALID)
forall a b.
Validator VALID (OperationContext VALID s) a
-> (a -> Validator VALID (OperationContext VALID s) b)
-> Validator VALID (OperationContext VALID s) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ref TypeName
-> HashMap TypeName (TypeDefinition ANY VALID)
-> Validator
     VALID (OperationContext VALID s) (TypeDefinition ANY VALID)
forall k (c :: * -> *) sel ctx a (s :: Stage).
(IsMap k c, Unknown sel ctx, KeyOf k sel) =>
sel -> c a -> Validator s ctx a
selectKnown (TypeName -> Position -> Ref TypeName
forall name. name -> Position -> Ref name
Ref TypeName
fragmentType Position
fragmentPosition)
  Constraint IMPLEMENTABLE
-> Fragment RAW
-> TypeDefinition ANY VALID
-> FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
forall (k :: TypeCategory) inp (s :: Stage) ctx.
KindViolation k inp =>
Constraint k
-> inp
-> TypeDefinition ANY s
-> Validator s ctx (TypeDefinition k s)
constraint Constraint IMPLEMENTABLE
IMPLEMENTABLE Fragment RAW
fr TypeDefinition ANY VALID
typeDef