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

module Data.Morpheus.Validation.Query.FragmentPreconditions
  ( checkFragmentPreconditions,
  )
where

import Data.Morpheus.Error.Fragment
  ( cannotSpreadWithinItself,
  )
import Data.Morpheus.Internal.Graph
  ( Edges,
    Graph,
    Node,
    cycleChecking,
  )
import Data.Morpheus.Internal.Utils
  ( Failure (..),
    elems,
    selectOr,
  )
import Data.Morpheus.Types.Internal.AST
  ( FieldName,
    Fragment (..),
    Fragments,
    RAW,
    Ref (..),
    Selection (..),
    SelectionContent (..),
    SelectionSet,
  )
import Data.Morpheus.Types.Internal.Validation
  ( BaseValidator,
    askFragments,
    checkUnused,
  )
import Relude

checkUnusedFragments :: SelectionSet RAW -> BaseValidator ()
checkUnusedFragments :: SelectionSet RAW -> BaseValidator ()
checkUnusedFragments SelectionSet RAW
selectionSet = do
  Fragments RAW
fragments <- Validator VALID (OperationContext RAW RAW) (Fragments RAW)
forall (m :: * -> * -> *) (s :: Stage) c (s' :: Stage).
(MonadContext m s c, GetWith c (Fragments s')) =>
m c (Fragments s')
askFragments
  [Node FieldName] -> [Fragment RAW] -> BaseValidator ()
forall k b a ca ctx (s :: Stage).
(KeyOf k b, Selectable k a ca, Unused ctx b) =>
ca -> [b] -> Validator s ctx ()
checkUnused
    (Fragments RAW -> [Selection RAW] -> [Node FieldName]
usedFragments Fragments RAW
fragments (SelectionSet RAW -> [Selection RAW]
forall a coll. Elems a coll => coll -> [a]
elems SelectionSet RAW
selectionSet))
    (Fragments RAW -> [Fragment RAW]
forall a coll. Elems a coll => coll -> [a]
elems Fragments RAW
fragments)

usedFragments :: Fragments RAW -> [Selection RAW] -> [Node FieldName]
usedFragments :: Fragments RAW -> [Selection RAW] -> [Node FieldName]
usedFragments Fragments RAW
fragments = (Selection RAW -> [Node FieldName])
-> [Selection RAW] -> [Node FieldName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node FieldName]
findAllUses
  where
    findUsesSelectionContent :: SelectionContent RAW -> [Node FieldName]
    findUsesSelectionContent :: SelectionContent RAW -> [Node FieldName]
findUsesSelectionContent (SelectionSet SelectionSet RAW
selectionSet) =
      (Selection RAW -> [Node FieldName])
-> SelectionSet RAW -> [Node FieldName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node FieldName]
findAllUses SelectionSet RAW
selectionSet
    findUsesSelectionContent SelectionContent RAW
SelectionField = []
    findAllUses :: Selection RAW -> [Node FieldName]
    findAllUses :: Selection RAW -> [Node FieldName]
findAllUses Selection {SelectionContent RAW
selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionContent :: SelectionContent RAW
selectionContent} =
      SelectionContent RAW -> [Node FieldName]
findUsesSelectionContent SelectionContent RAW
selectionContent
    findAllUses (InlineFragment Fragment {SelectionSet RAW
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection :: SelectionSet RAW
fragmentSelection}) =
      (Selection RAW -> [Node FieldName])
-> SelectionSet RAW -> [Node FieldName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node FieldName]
findAllUses SelectionSet RAW
fragmentSelection
    findAllUses (Spread Directives RAW
_ Ref {FieldName
refName :: forall name. Ref name -> name
refName :: FieldName
refName, Position
refPosition :: forall name. Ref name -> Position
refPosition :: Position
refPosition}) =
      [FieldName -> Position -> Node FieldName
forall name. name -> Position -> Ref name
Ref FieldName
refName Position
refPosition] [Node FieldName] -> [Node FieldName] -> [Node FieldName]
forall a. Semigroup a => a -> a -> a
<> [Node FieldName]
searchInFragment
      where
        searchInFragment :: [Node FieldName]
searchInFragment =
          [Node FieldName]
-> (Fragment RAW -> [Node FieldName])
-> FieldName
-> Fragments RAW
-> [Node FieldName]
forall k a c d. Selectable k a c => d -> (a -> d) -> k -> c -> d
selectOr
            []
            ((Selection RAW -> [Node FieldName])
-> SelectionSet RAW -> [Node FieldName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node FieldName]
findAllUses (SelectionSet RAW -> [Node FieldName])
-> (Fragment RAW -> SelectionSet RAW)
-> Fragment RAW
-> [Node FieldName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fragment RAW -> SelectionSet RAW
forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection)
            FieldName
refName
            Fragments RAW
fragments

checkFragmentPreconditions :: SelectionSet RAW -> BaseValidator ()
checkFragmentPreconditions :: SelectionSet RAW -> BaseValidator ()
checkFragmentPreconditions SelectionSet RAW
selection =
  (BaseValidator (Graph FieldName)
exploreSpreads BaseValidator (Graph FieldName)
-> (Graph FieldName -> BaseValidator ()) -> BaseValidator ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (NonEmpty (Node FieldName) -> BaseValidator ())
-> Graph FieldName -> BaseValidator ()
forall (m :: * -> *) name.
(Applicative m, Eq name) =>
(NonEmpty (Ref name) -> m ()) -> Graph name -> m ()
cycleChecking (ValidationError -> BaseValidator ()
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (ValidationError -> BaseValidator ())
-> (NonEmpty (Node FieldName) -> ValidationError)
-> NonEmpty (Node FieldName)
-> BaseValidator ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Node FieldName) -> ValidationError
cannotSpreadWithinItself))
    BaseValidator () -> BaseValidator () -> BaseValidator ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> SelectionSet RAW -> BaseValidator ()
checkUnusedFragments SelectionSet RAW
selection

exploreSpreads :: BaseValidator (Graph FieldName)
exploreSpreads :: BaseValidator (Graph FieldName)
exploreSpreads = (Fragment RAW -> Edges FieldName)
-> [Fragment RAW] -> Graph FieldName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fragment RAW -> Edges FieldName
exploreFragmentSpreads ([Fragment RAW] -> Graph FieldName)
-> (Fragments RAW -> [Fragment RAW])
-> Fragments RAW
-> Graph FieldName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fragments RAW -> [Fragment RAW]
forall a coll. Elems a coll => coll -> [a]
elems (Fragments RAW -> Graph FieldName)
-> Validator VALID (OperationContext RAW RAW) (Fragments RAW)
-> BaseValidator (Graph FieldName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Validator VALID (OperationContext RAW RAW) (Fragments RAW)
forall (m :: * -> * -> *) (s :: Stage) c (s' :: Stage).
(MonadContext m s c, GetWith c (Fragments s')) =>
m c (Fragments s')
askFragments

exploreFragmentSpreads :: Fragment RAW -> Edges FieldName
exploreFragmentSpreads :: Fragment RAW -> Edges FieldName
exploreFragmentSpreads Fragment {FieldName
fragmentName :: forall (stage :: Stage). Fragment stage -> FieldName
fragmentName :: FieldName
fragmentName, SelectionSet RAW
fragmentSelection :: SelectionSet RAW
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection, Position
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentPosition :: Position
fragmentPosition} =
  (FieldName -> Position -> Node FieldName
forall name. name -> Position -> Ref name
Ref FieldName
fragmentName Position
fragmentPosition, (Selection RAW -> [Node FieldName])
-> SelectionSet RAW -> [Node FieldName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node FieldName]
forall a. ScanSpread a => a -> [Node FieldName]
scanSpread SelectionSet RAW
fragmentSelection)

class ScanSpread a where
  scanSpread :: a -> [Node FieldName]

instance ScanSpread (Selection RAW) where
  scanSpread :: Selection RAW -> [Node FieldName]
scanSpread Selection {SelectionContent RAW
selectionContent :: SelectionContent RAW
selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionContent} =
    SelectionContent RAW -> [Node FieldName]
forall a. ScanSpread a => a -> [Node FieldName]
scanSpread SelectionContent RAW
selectionContent
  scanSpread (InlineFragment Fragment {SelectionSet RAW
fragmentSelection :: SelectionSet RAW
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection}) =
    (Selection RAW -> [Node FieldName])
-> SelectionSet RAW -> [Node FieldName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node FieldName]
forall a. ScanSpread a => a -> [Node FieldName]
scanSpread SelectionSet RAW
fragmentSelection
  scanSpread (Spread Directives RAW
_ Ref {FieldName
refName :: FieldName
refName :: forall name. Ref name -> name
refName, Position
refPosition :: Position
refPosition :: forall name. Ref name -> Position
refPosition}) =
    [FieldName -> Position -> Node FieldName
forall name. name -> Position -> Ref name
Ref FieldName
refName Position
refPosition]

instance ScanSpread (SelectionContent RAW) where
  scanSpread :: SelectionContent RAW -> [Node FieldName]
scanSpread SelectionContent RAW
SelectionField = []
  scanSpread (SelectionSet SelectionSet RAW
selectionSet) =
    (Selection RAW -> [Node FieldName])
-> SelectionSet RAW -> [Node FieldName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node FieldName]
forall a. ScanSpread a => a -> [Node FieldName]
scanSpread SelectionSet RAW
selectionSet