{-# 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
  ( 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] -> [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]
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]
usedFragments :: Fragments RAW -> [Selection RAW] -> [Node]
usedFragments Fragments RAW
fragments = (Selection RAW -> [Node]) -> [Selection RAW] -> [Node]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node]
findAllUses
  where
    findUsesSelectionContent :: SelectionContent RAW -> [Node]
    findUsesSelectionContent :: SelectionContent RAW -> [Node]
findUsesSelectionContent (SelectionSet SelectionSet RAW
selectionSet) =
      (Selection RAW -> [Node]) -> SelectionSet RAW -> [Node]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node]
findAllUses SelectionSet RAW
selectionSet
    findUsesSelectionContent SelectionContent RAW
SelectionField = []
    findAllUses :: Selection RAW -> [Node]
    findAllUses :: Selection RAW -> [Node]
findAllUses Selection {SelectionContent RAW
selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionContent :: SelectionContent RAW
selectionContent} =
      SelectionContent RAW -> [Node]
findUsesSelectionContent SelectionContent RAW
selectionContent
    findAllUses (InlineFragment Fragment {SelectionSet RAW
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection :: SelectionSet RAW
fragmentSelection}) =
      (Selection RAW -> [Node]) -> SelectionSet RAW -> [Node]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node]
findAllUses SelectionSet RAW
fragmentSelection
    findAllUses (Spread Directives RAW
_ Ref {FieldName
refName :: Node -> FieldName
refName :: FieldName
refName, Position
refPosition :: Node -> Position
refPosition :: Position
refPosition}) =
      [FieldName -> Position -> Node
Ref FieldName
refName Position
refPosition] [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node]
searchInFragment
      where
        searchInFragment :: [Node]
searchInFragment =
          [Node]
-> (Fragment RAW -> [Node]) -> FieldName -> Fragments RAW -> [Node]
forall k a c d. Selectable k a c => d -> (a -> d) -> k -> c -> d
selectOr
            []
            ((Selection RAW -> [Node]) -> SelectionSet RAW -> [Node]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node]
findAllUses (SelectionSet RAW -> [Node])
-> (Fragment RAW -> SelectionSet RAW) -> Fragment RAW -> [Node]
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
exploreSpreads BaseValidator Graph
-> (Graph -> BaseValidator ()) -> BaseValidator ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (NonEmpty Node -> BaseValidator ()) -> Graph -> BaseValidator ()
forall (m :: * -> *).
Applicative m =>
(NonEmpty Node -> m ()) -> Graph -> m ()
cycleChecking (ValidationError -> BaseValidator ()
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (ValidationError -> BaseValidator ())
-> (NonEmpty Node -> ValidationError)
-> NonEmpty Node
-> BaseValidator ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Node -> 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
exploreSpreads :: BaseValidator Graph
exploreSpreads = (Fragment RAW -> Edges) -> [Fragment RAW] -> Graph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fragment RAW -> Edges
exploreFragmentSpreads ([Fragment RAW] -> Graph)
-> (Fragments RAW -> [Fragment RAW]) -> Fragments RAW -> Graph
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)
-> Validator VALID (OperationContext RAW RAW) (Fragments RAW)
-> BaseValidator Graph
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
exploreFragmentSpreads :: Fragment RAW -> Edges
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
Ref FieldName
fragmentName Position
fragmentPosition, (Selection RAW -> [Node]) -> SelectionSet RAW -> [Node]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Node]
forall a. ScanSpread a => a -> [Node]
scanSpread SelectionSet RAW
fragmentSelection)

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

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

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