{-# 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 Control.Monad.Except (throwError)
import Data.Mergeable
import Data.Morpheus.Error.Fragment
  ( cannotSpreadWithinItself,
  )
import Data.Morpheus.Internal.Graph
  ( Edges,
    Graph,
    Node,
    cycleChecking,
  )
import Data.Morpheus.Internal.Utils
  ( selectOr,
  )
import Data.Morpheus.Types.Internal.AST
  ( Fragment (..),
    FragmentName,
    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 <- forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *).
MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m =>
m (Fragments s3)
askFragments
  HashMap FragmentName [Ref FragmentName]
usages <- Fragments RAW
-> SelectionSet RAW
-> BaseValidator (HashMap FragmentName [Ref FragmentName])
usedFragments Fragments RAW
fragments SelectionSet RAW
selectionSet
  forall k b (c :: * -> *) (t :: * -> *) a (s :: Stage) (s1 :: Stage)
       (s2 :: Stage).
(KeyOf k b, IsMap k c, Unused b, Foldable t) =>
c a -> t b -> Validator s (OperationContext s1 s2) ()
checkUnused HashMap FragmentName [Ref FragmentName]
usages Fragments RAW
fragments

usedFragments :: Fragments RAW -> SelectionSet RAW -> BaseValidator (HashMap FragmentName [Node FragmentName])
usedFragments :: Fragments RAW
-> SelectionSet RAW
-> BaseValidator (HashMap FragmentName [Ref FragmentName])
usedFragments Fragments RAW
fragments = forall k (m :: * -> *) v.
(Eq k, Hashable k, Monad m, Semigroup v) =>
[(k, v)] -> m (HashMap k v)
collect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {name}. Ref name -> (name, [Ref name])
toEntry forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Ref FragmentName]
findAllUses forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
  where
    toEntry :: Ref name -> (name, [Ref name])
toEntry (Ref name
x Position
y) = (name
x, [forall name. name -> Position -> Ref name
Ref name
x Position
y])
    findUsesSelectionContent :: SelectionContent RAW -> [Node FragmentName]
    findUsesSelectionContent :: SelectionContent RAW -> [Ref FragmentName]
findUsesSelectionContent (SelectionSet SelectionSet RAW
selectionSet) =
      forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Ref FragmentName]
findAllUses SelectionSet RAW
selectionSet
    findUsesSelectionContent SelectionContent RAW
SelectionField = []
    findAllUses :: Selection RAW -> [Node FragmentName]
    findAllUses :: Selection RAW -> [Ref FragmentName]
findAllUses Selection {SelectionContent RAW
selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionContent :: SelectionContent RAW
selectionContent} =
      SelectionContent RAW -> [Ref FragmentName]
findUsesSelectionContent SelectionContent RAW
selectionContent
    findAllUses (InlineFragment Fragment {SelectionSet RAW
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection :: SelectionSet RAW
fragmentSelection}) =
      forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Ref FragmentName]
findAllUses SelectionSet RAW
fragmentSelection
    findAllUses (Spread Directives RAW
_ Ref {FragmentName
refName :: forall name. Ref name -> name
refName :: FragmentName
refName, Position
refPosition :: forall name. Ref name -> Position
refPosition :: Position
refPosition}) =
      [forall name. name -> Position -> Ref name
Ref FragmentName
refName Position
refPosition] forall a. Semigroup a => a -> a -> a
<> [Ref FragmentName]
searchInFragment
      where
        searchInFragment :: [Ref FragmentName]
searchInFragment =
          forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr
            []
            (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection RAW -> [Ref FragmentName]
findAllUses forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection)
            FragmentName
refName
            Fragments RAW
fragments

checkFragmentPreconditions :: SelectionSet RAW -> BaseValidator ()
checkFragmentPreconditions :: SelectionSet RAW -> BaseValidator ()
checkFragmentPreconditions SelectionSet RAW
selection =
  (BaseValidator (Graph FragmentName)
exploreSpreads forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall name (m :: * -> *).
(Eq name, Monad m) =>
(NonEmpty (Ref name) -> m ()) -> Graph name -> m ()
cycleChecking (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Ref FragmentName) -> GQLError
cannotSpreadWithinItself))
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> SelectionSet RAW -> BaseValidator ()
checkUnusedFragments SelectionSet RAW
selection

exploreSpreads :: BaseValidator (Graph FragmentName)
exploreSpreads :: BaseValidator (Graph FragmentName)
exploreSpreads = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fragment RAW -> Edges FragmentName
exploreFragmentSpreads forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *).
MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m =>
m (Fragments s3)
askFragments

exploreFragmentSpreads :: Fragment RAW -> Edges FragmentName
exploreFragmentSpreads :: Fragment RAW -> Edges FragmentName
exploreFragmentSpreads Fragment {FragmentName
fragmentName :: forall (stage :: Stage). Fragment stage -> FragmentName
fragmentName :: FragmentName
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} =
  (forall name. name -> Position -> Ref name
Ref FragmentName
fragmentName Position
fragmentPosition, forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. ScanSpread a => a -> [Ref FragmentName]
scanSpread SelectionSet RAW
fragmentSelection)

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

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

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