{-# 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)
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentType :: TypeName
fragmentType, FragmentName
fragmentName :: forall (stage :: Stage). Fragment stage -> FragmentName
fragmentName :: FragmentName
fragmentName} <- forall (s :: Stage).
[TypeName] -> Ref FragmentName -> FragmentValidator s (Fragment s)
resolveSpread [TypeName]
allowedTargets Ref FragmentName
ref
  TypeName -> SelectionSet VALID -> UnionTag
UnionTag TypeName
fragmentType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Selection VALID
s -> Selection VALID
s {selectionOrigin :: Maybe FragmentName
selectionOrigin = forall a. a -> Maybe a
Just FragmentName
fragmentName}) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (s :: Stage) (m :: * -> *).
(ValidateFragmentSelection s, 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 :: forall (stage :: Stage). Fragment stage -> Position
fragmentPosition :: Position
fragmentPosition} =
  forall (s :: Stage) (s1 :: Stage).
Maybe FragmentName
-> Position
-> [TypeName]
-> Fragment s
-> FragmentValidator s1 (Fragment s)
castFragmentType forall a. Maybe a
Nothing Position
fragmentPosition [TypeName]
allowedTypes Fragment RAW
fragment
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 = forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *).
MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m =>
m (Fragments s3)
askFragments forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (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
fragmentDirectives :: forall (stage :: Stage). Fragment stage -> Directives stage
fragmentDirectives :: Directives RAW
fragmentSelection :: SelectionSet RAW
fragmentPosition :: Position
fragmentType :: TypeName
fragmentName :: FragmentName
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentName :: forall (stage :: Stage). Fragment stage -> FragmentName
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
..} =
  forall (stage :: Stage).
FragmentName
-> TypeName
-> Position
-> SelectionSet stage
-> Directives stage
-> Fragment stage
Fragment
    FragmentName
fragmentName
    TypeName
fragmentType
    Position
fragmentPosition
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validate Fragment RAW
f
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 :: TypeName
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentType}
  | TypeName
fragmentType forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TypeName]
typeMembers = forall (f :: * -> *) a. Applicative f => a -> f a
pure Fragment s
fragment
  | Bool
otherwise = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError 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 :: forall name. Ref name -> name
refName :: FragmentName
refName, Position
refPosition :: forall name. Ref name -> Position
refPosition :: Position
refPosition} =
  forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *).
MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m =>
m (Fragments s3)
askFragments
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (s :: Stage) (s1 :: Stage).
Maybe FragmentName
-> Position
-> [TypeName]
-> Fragment s
-> FragmentValidator s1 (Fragment s)
castFragmentType (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 :: TypeName
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentType, Position
fragmentPosition :: Position
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentPosition} = do
  TypeDefinition ANY VALID
typeDef <- forall (s :: Stage) ctx (m :: * -> *).
MonadReader (ValidatorContext s ctx) m =>
m (HashMap TypeName (TypeDefinition ANY s))
askTypeDefinitions forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 (forall name. name -> Position -> Ref name
Ref TypeName
fragmentType Position
fragmentPosition)
  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