{-# 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,
    resolveSpread,
    validateFragment,
    selectFragmentType,
    ResolveFragment (..),
  )
where

import Data.Morpheus.Error.Fragment
  ( cannotBeSpreadOnType,
  )
import Data.Morpheus.Internal.Utils
  ( Failure (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( Directives,
    FieldName,
    Fragment (..),
    Fragments,
    IMPLEMENTABLE,
    Position,
    RAW,
    Ref (..),
    Schema,
    SelectionSet,
    Stage,
    Stage,
    TypeDefinition,
    TypeName,
    TypeNameRef (..),
    UnionTag (..),
    VALID,
  )
import Data.Morpheus.Types.Internal.Validation
  ( Constraint (..),
    FragmentValidator,
    askFragments,
    askSchema,
    constraint,
    selectKnown,
  )
import Relude

class ResolveFragment (s :: Stage) where
  resolveValidFragment ::
    (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) ->
    [TypeName] ->
    Ref ->
    FragmentValidator s UnionTag

instance ResolveFragment VALID where
  resolveValidFragment :: (Fragment RAW -> FragmentValidator VALID (SelectionSet VALID))
-> [TypeName] -> Ref -> FragmentValidator VALID UnionTag
resolveValidFragment Fragment RAW -> FragmentValidator VALID (SelectionSet VALID)
_ [TypeName]
allowedTargets Ref
ref = do
    Fragment {TypeName
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentType :: TypeName
fragmentType, SelectionSet VALID
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection :: SelectionSet VALID
fragmentSelection} <- [TypeName] -> Ref -> FragmentValidator VALID (Fragment VALID)
forall (s :: Stage).
[TypeName] -> Ref -> FragmentValidator s (Fragment s)
resolveSpread [TypeName]
allowedTargets Ref
ref
    UnionTag -> FragmentValidator VALID UnionTag
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnionTag -> FragmentValidator VALID UnionTag)
-> UnionTag -> FragmentValidator VALID UnionTag
forall a b. (a -> b) -> a -> b
$ TypeName -> SelectionSet VALID -> UnionTag
UnionTag TypeName
fragmentType SelectionSet VALID
fragmentSelection

instance ResolveFragment RAW where
  resolveValidFragment :: (Fragment RAW -> FragmentValidator RAW (SelectionSet VALID))
-> [TypeName] -> Ref -> FragmentValidator RAW UnionTag
resolveValidFragment Fragment RAW -> FragmentValidator RAW (SelectionSet VALID)
f [TypeName]
allowedTargets Ref
ref = do
    fragment :: Fragment RAW
fragment@Fragment {TypeName
fragmentType :: TypeName
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentType} <- [TypeName] -> Ref -> FragmentValidator RAW (Fragment RAW)
forall (s :: Stage).
[TypeName] -> Ref -> FragmentValidator s (Fragment s)
resolveSpread [TypeName]
allowedTargets Ref
ref
    TypeName -> SelectionSet VALID -> UnionTag
UnionTag TypeName
fragmentType (SelectionSet VALID -> UnionTag)
-> FragmentValidator RAW (SelectionSet VALID)
-> FragmentValidator RAW UnionTag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fragment RAW -> FragmentValidator RAW (SelectionSet VALID)
f Fragment RAW
fragment

validateFragment ::
  (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) ->
  [TypeName] ->
  Fragment RAW ->
  FragmentValidator s (Fragment VALID)
validateFragment :: (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeName]
-> Fragment RAW
-> FragmentValidator s (Fragment VALID)
validateFragment 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} =
  Maybe FieldName
-> Position
-> [TypeName]
-> Fragment RAW
-> FragmentValidator s (Fragment RAW)
forall (s :: Stage) (s1 :: Stage).
Maybe FieldName
-> Position
-> [TypeName]
-> Fragment s
-> FragmentValidator s1 (Fragment s)
castFragmentType Maybe FieldName
forall a. Maybe a
Nothing Position
fragmentPosition [TypeName]
allowedTypes Fragment RAW
fragment
    FragmentValidator s (Fragment RAW)
-> (Fragment RAW -> FragmentValidator s (Fragment VALID))
-> FragmentValidator s (Fragment VALID)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> Fragment RAW -> FragmentValidator s (Fragment VALID)
forall (s :: Stage).
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> Fragment RAW -> FragmentValidator s (Fragment VALID)
onlyValidateFrag 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 (m :: * -> * -> *) (s :: Stage) c (s' :: Stage).
(MonadContext m s c, GetWith c (Fragments s')) =>
m c (Fragments s')
askFragments Validator VALID (OperationContext VALID RAW) (Fragments RAW)
-> (Fragments RAW -> FragmentValidator RAW (Fragments VALID))
-> FragmentValidator RAW (Fragments VALID)
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)
traverse ((Fragment RAW -> FragmentValidator RAW (SelectionSet VALID))
-> Fragment RAW
-> Validator VALID (OperationContext VALID RAW) (Fragment VALID)
forall (s :: Stage).
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> Fragment RAW -> FragmentValidator s (Fragment VALID)
onlyValidateFrag Fragment RAW -> FragmentValidator RAW (SelectionSet VALID)
f)

onlyValidateFrag ::
  (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) ->
  Fragment RAW ->
  FragmentValidator s (Fragment VALID)
onlyValidateFrag :: (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> Fragment RAW -> FragmentValidator s (Fragment VALID)
onlyValidateFrag Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validate f :: Fragment RAW
f@Fragment {Directives RAW
Position
TypeName
FieldName
SelectionSet RAW
fragmentDirectives :: forall (stage :: Stage). Fragment stage -> Directives stage
fragmentName :: forall (stage :: Stage). Fragment stage -> FieldName
fragmentDirectives :: Directives RAW
fragmentSelection :: SelectionSet RAW
fragmentPosition :: Position
fragmentType :: TypeName
fragmentName :: FieldName
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
..} =
  FieldName
-> TypeName
-> Position
-> SelectionSet VALID
-> Directives VALID
-> Fragment VALID
forall (stage :: Stage).
FieldName
-> TypeName
-> Position
-> SelectionSet stage
-> Directives stage
-> Fragment stage
Fragment
    FieldName
fragmentName
    TypeName
fragmentType
    Position
fragmentPosition
    (SelectionSet VALID -> Directives VALID -> Fragment VALID)
-> FragmentValidator s (SelectionSet 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)
-> FragmentValidator s (Fragment VALID)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Directives RAW
-> Validator VALID (OperationContext VALID s) (Directives VALID)
forall (s :: Stage).
Directives RAW -> FragmentValidator s (Directives VALID)
validateFragmentDirectives Directives RAW
fragmentDirectives

validateFragmentDirectives :: Directives RAW -> FragmentValidator s (Directives VALID)
validateFragmentDirectives :: Directives RAW -> FragmentValidator s (Directives VALID)
validateFragmentDirectives Directives RAW
_ = Directives VALID -> FragmentValidator s (Directives VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] --TODO: validate fragment directives

castFragmentType ::
  Maybe FieldName ->
  Position ->
  [TypeName] ->
  Fragment s ->
  FragmentValidator s1 (Fragment s)
castFragmentType :: Maybe FieldName
-> Position
-> [TypeName]
-> Fragment s
-> FragmentValidator s1 (Fragment s)
castFragmentType Maybe FieldName
key Position
position [TypeName]
typeMembers fragment :: Fragment s
fragment@Fragment {TypeName
fragmentType :: TypeName
fragmentType :: forall (stage :: Stage). Fragment stage -> 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 -> FragmentValidator s1 (Fragment s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Fragment s
fragment
  | Bool
otherwise = ValidationError -> FragmentValidator s1 (Fragment s)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (ValidationError -> FragmentValidator s1 (Fragment s))
-> ValidationError -> FragmentValidator s1 (Fragment s)
forall a b. (a -> b) -> a -> b
$ Maybe FieldName
-> TypeName -> Position -> [TypeName] -> ValidationError
cannotBeSpreadOnType Maybe FieldName
key TypeName
fragmentType Position
position [TypeName]
typeMembers

resolveSpread :: [TypeName] -> Ref -> FragmentValidator s (Fragment s)
resolveSpread :: [TypeName] -> Ref -> FragmentValidator s (Fragment s)
resolveSpread [TypeName]
allowedTargets ref :: Ref
ref@Ref {FieldName
refName :: Ref -> FieldName
refName :: FieldName
refName, Position
refPosition :: Ref -> Position
refPosition :: Position
refPosition} =
  Validator VALID (OperationContext VALID s) (Fragments s)
forall (m :: * -> * -> *) (s :: Stage) c (s' :: Stage).
(MonadContext m s c, GetWith c (Fragments s')) =>
m c (Fragments s')
askFragments
    Validator VALID (OperationContext VALID s) (Fragments s)
-> (Fragments s -> FragmentValidator s (Fragment s))
-> FragmentValidator s (Fragment s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ref -> Fragments s -> FragmentValidator s (Fragment s)
forall k a c sel ctx (s :: Stage).
(Selectable k a c, Unknown c sel ctx, KeyOf k sel) =>
sel -> c -> Validator s ctx a
selectKnown Ref
ref
    FragmentValidator s (Fragment s)
-> (Fragment s -> FragmentValidator s (Fragment s))
-> FragmentValidator s (Fragment s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe FieldName
-> Position
-> [TypeName]
-> Fragment s
-> FragmentValidator s (Fragment s)
forall (s :: Stage) (s1 :: Stage).
Maybe FieldName
-> Position
-> [TypeName]
-> Fragment s
-> FragmentValidator s1 (Fragment s)
castFragmentType (FieldName -> Maybe FieldName
forall a. a -> Maybe a
Just FieldName
refName) Position
refPosition [TypeName]
allowedTargets

selectFragmentType :: Fragment RAW -> FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
selectFragmentType :: 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
  (Schema VALID
schema :: Schema VALID) <- Validator VALID (OperationContext VALID s) (Schema VALID)
forall (m :: * -> * -> *) (s :: Stage) c.
MonadContext m s c =>
m c (Schema s)
askSchema
  TypeDefinition ANY VALID
typeDef <- TypeNameRef
-> Schema VALID
-> Validator
     VALID (OperationContext VALID s) (TypeDefinition ANY VALID)
forall k a c sel ctx (s :: Stage).
(Selectable k a c, Unknown c sel ctx, KeyOf k sel) =>
sel -> c -> Validator s ctx a
selectKnown (TypeName -> Position -> TypeNameRef
TypeNameRef TypeName
fragmentType Position
fragmentPosition) Schema VALID
schema
  Constraint 'TARGET_IMPLEMENTABLE
-> Fragment RAW
-> TypeDefinition ANY VALID
-> Validator
     VALID
     (OperationContext VALID s)
     (Resolution VALID 'TARGET_IMPLEMENTABLE)
forall (a :: Target) inp (s :: Stage) ctx.
KindViolation a inp =>
Constraint a
-> inp -> TypeDefinition ANY s -> Validator s ctx (Resolution s a)
constraint Constraint 'TARGET_IMPLEMENTABLE
IMPLEMENTABLE Fragment RAW
fr TypeDefinition ANY VALID
typeDef