{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Types.Internal.AST.Selection
  ( Selection (..),
    SelectionContent (..),
    SelectionSet,
    UnionTag (..),
    UnionSelection,
    Fragment (..),
    Fragments,
    Operation (..),
    Variable (..),
    VariableDefinitions,
    DefaultValue,
    getOperationName,
    getOperationDataType,
    splitSystemSelection,
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.Foldable (foldr')
import Data.Mergeable
  ( Merge (..),
    MergeMap,
    NameCollision (..),
    OrdMap,
  )
import Data.Mergeable.MergeMap (partition)
import Data.Morpheus.Error.Operation
  ( mutationIsNotDefined,
    subscriptionIsNotDefined,
  )
import Data.Morpheus.Internal.Utils
  ( (<:>),
    HistoryT,
    KeyOf (..),
    addPath,
  )
import Data.Morpheus.Rendering.RenderGQL
  ( RenderGQL (..),
    Rendering,
    newline,
    renderObject,
    space,
  )
import Data.Morpheus.Types.Internal.AST.Base
  ( Position,
    Ref (..),
  )
import Data.Morpheus.Types.Internal.AST.Error
  ( GQLError,
    at,
    atPositions,
    msg,
  )
import Data.Morpheus.Types.Internal.AST.Fields
  ( Arguments,
    Directives,
    renderArgumentValues,
    renderDirectives,
  )
import Data.Morpheus.Types.Internal.AST.Name
  ( FieldName,
    FragmentName,
    TypeName,
    intercalate,
    isNotSystemFieldName,
  )
import Data.Morpheus.Types.Internal.AST.OperationType (OperationType (..))
import Data.Morpheus.Types.Internal.AST.Stage
  ( ALLOW_DUPLICATES,
    RAW,
    Stage,
    VALID,
  )
import Data.Morpheus.Types.Internal.AST.TypeCategory
  ( OBJECT,
  )
import Data.Morpheus.Types.Internal.AST.TypeSystem
  ( Schema (..),
    TypeDefinition (..),
  )
import Data.Morpheus.Types.Internal.AST.Value
  ( ResolvedValue,
    Variable (..),
    VariableDefinitions,
  )
import Language.Haskell.TH.Syntax (Lift (..))
import Relude hiding (intercalate, show)
import Prelude (show)

data Fragment (stage :: Stage) = Fragment
  { Fragment stage -> FragmentName
fragmentName :: FragmentName,
    Fragment stage -> TypeName
fragmentType :: TypeName,
    Fragment stage -> Position
fragmentPosition :: Position,
    Fragment stage -> SelectionSet stage
fragmentSelection :: SelectionSet stage,
    Fragment stage -> Directives stage
fragmentDirectives :: Directives stage
  }
  deriving (Int -> Fragment stage -> ShowS
[Fragment stage] -> ShowS
Fragment stage -> String
(Int -> Fragment stage -> ShowS)
-> (Fragment stage -> String)
-> ([Fragment stage] -> ShowS)
-> Show (Fragment stage)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (stage :: Stage). Int -> Fragment stage -> ShowS
forall (stage :: Stage). [Fragment stage] -> ShowS
forall (stage :: Stage). Fragment stage -> String
showList :: [Fragment stage] -> ShowS
$cshowList :: forall (stage :: Stage). [Fragment stage] -> ShowS
show :: Fragment stage -> String
$cshow :: forall (stage :: Stage). Fragment stage -> String
showsPrec :: Int -> Fragment stage -> ShowS
$cshowsPrec :: forall (stage :: Stage). Int -> Fragment stage -> ShowS
Show, Fragment stage -> Fragment stage -> Bool
(Fragment stage -> Fragment stage -> Bool)
-> (Fragment stage -> Fragment stage -> Bool)
-> Eq (Fragment stage)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (stage :: Stage). Fragment stage -> Fragment stage -> Bool
/= :: Fragment stage -> Fragment stage -> Bool
$c/= :: forall (stage :: Stage). Fragment stage -> Fragment stage -> Bool
== :: Fragment stage -> Fragment stage -> Bool
$c== :: forall (stage :: Stage). Fragment stage -> Fragment stage -> Bool
Eq, Fragment stage -> Q Exp
Fragment stage -> Q (TExp (Fragment stage))
(Fragment stage -> Q Exp)
-> (Fragment stage -> Q (TExp (Fragment stage)))
-> Lift (Fragment stage)
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
forall (stage :: Stage). Fragment stage -> Q Exp
forall (stage :: Stage).
Fragment stage -> Q (TExp (Fragment stage))
liftTyped :: Fragment stage -> Q (TExp (Fragment stage))
$cliftTyped :: forall (stage :: Stage).
Fragment stage -> Q (TExp (Fragment stage))
lift :: Fragment stage -> Q Exp
$clift :: forall (stage :: Stage). Fragment stage -> Q Exp
Lift)

-- ERRORs
instance NameCollision GQLError (Fragment s) where
  nameCollision :: Fragment s -> GQLError
nameCollision Fragment {FragmentName
fragmentName :: FragmentName
fragmentName :: forall (stage :: Stage). Fragment stage -> FragmentName
fragmentName, Position
fragmentPosition :: Position
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentPosition} =
    (GQLError
"There can be only one fragment named " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> FragmentName -> GQLError
forall a. Msg a => a -> GQLError
msg FragmentName
fragmentName GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
".")
      GQLError -> Position -> GQLError
`at` Position
fragmentPosition

instance KeyOf FragmentName (Fragment s) where
  keyOf :: Fragment s -> FragmentName
keyOf = Fragment s -> FragmentName
forall (stage :: Stage). Fragment stage -> FragmentName
fragmentName

type Fragments (s :: Stage) = OrdMap FragmentName (Fragment s)

data SelectionContent (s :: Stage) where
  SelectionField :: SelectionContent s
  SelectionSet :: SelectionSet s -> SelectionContent s
  UnionSelection ::
    { SelectionContent VALID -> SelectionSet VALID
defaultSelection :: SelectionSet VALID,
      SelectionContent VALID -> UnionSelection VALID
conditionalSelections :: UnionSelection VALID
    } ->
    SelectionContent VALID

renderSelectionSet :: SelectionSet VALID -> Rendering
renderSelectionSet :: SelectionSet VALID -> Rendering
renderSelectionSet = [Selection VALID] -> Rendering
forall a. RenderGQL a => [a] -> Rendering
renderObject ([Selection VALID] -> Rendering)
-> (MergeMap 'False FieldName (Selection VALID)
    -> [Selection VALID])
-> MergeMap 'False FieldName (Selection VALID)
-> Rendering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MergeMap 'False FieldName (Selection VALID) -> [Selection VALID]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance RenderGQL (SelectionContent VALID) where
  renderGQL :: SelectionContent VALID -> Rendering
renderGQL SelectionContent VALID
SelectionField = Rendering
""
  renderGQL (SelectionSet SelectionSet VALID
selSet) = SelectionSet VALID -> Rendering
renderSelectionSet SelectionSet VALID
selSet
  renderGQL (UnionSelection SelectionSet VALID
interfaceFields UnionSelection VALID
unionSets) =
    [Either (Selection VALID) UnionTag] -> Rendering
forall a. RenderGQL a => [a] -> Rendering
renderObject [Either (Selection VALID) UnionTag]
unionSelectionElements
    where
      unionSelectionElements :: [Either (Selection VALID) UnionTag]
      unionSelectionElements :: [Either (Selection VALID) UnionTag]
unionSelectionElements =
        (Selection VALID -> Either (Selection VALID) UnionTag)
-> [Selection VALID] -> [Either (Selection VALID) UnionTag]
forall a b. (a -> b) -> [a] -> [b]
map Selection VALID -> Either (Selection VALID) UnionTag
forall a b. a -> Either a b
Left (MergeMap 'False FieldName (Selection VALID) -> [Selection VALID]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList MergeMap 'False FieldName (Selection VALID)
SelectionSet VALID
interfaceFields)
          [Either (Selection VALID) UnionTag]
-> [Either (Selection VALID) UnionTag]
-> [Either (Selection VALID) UnionTag]
forall a. Semigroup a => a -> a -> a
<> (UnionTag -> Either (Selection VALID) UnionTag)
-> [UnionTag] -> [Either (Selection VALID) UnionTag]
forall a b. (a -> b) -> [a] -> [b]
map UnionTag -> Either (Selection VALID) UnionTag
forall a b. b -> Either a b
Right ((UnionTag -> TypeName) -> [UnionTag] -> [UnionTag]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn UnionTag -> TypeName
unionTagName ([UnionTag] -> [UnionTag]) -> [UnionTag] -> [UnionTag]
forall a b. (a -> b) -> a -> b
$ MergeMap 'False TypeName UnionTag -> [UnionTag]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList MergeMap 'False TypeName UnionTag
UnionSelection VALID
unionSets)

instance
  ( Monad m,
    MonadError GQLError m,
    Merge (HistoryT m) (SelectionSet s)
  ) =>
  Merge (HistoryT m) (SelectionContent s)
  where
  merge :: SelectionContent s
-> SelectionContent s -> HistoryT m (SelectionContent s)
merge (SelectionSet SelectionSet s
s1) (SelectionSet SelectionSet s
s2) = SelectionSet s -> SelectionContent s
forall (s :: Stage). SelectionSet s -> SelectionContent s
SelectionSet (SelectionSet s -> SelectionContent s)
-> ReaderT [Ref FieldName] m (SelectionSet s)
-> HistoryT m (SelectionContent s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SelectionSet s
-> SelectionSet s -> ReaderT [Ref FieldName] m (SelectionSet s)
forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge SelectionSet s
s1 SelectionSet s
s2
  merge (UnionSelection SelectionSet VALID
m1 UnionSelection VALID
u1) (UnionSelection SelectionSet VALID
m2 UnionSelection VALID
u2) = MergeMap 'False FieldName (Selection VALID)
-> MergeMap 'False TypeName UnionTag -> SelectionContent s
SelectionSet VALID
-> UnionSelection VALID -> SelectionContent VALID
UnionSelection (MergeMap 'False FieldName (Selection VALID)
 -> MergeMap 'False TypeName UnionTag -> SelectionContent s)
-> ReaderT
     [Ref FieldName] m (MergeMap 'False FieldName (Selection VALID))
-> ReaderT
     [Ref FieldName]
     m
     (MergeMap 'False TypeName UnionTag -> SelectionContent s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MergeMap 'False FieldName (Selection VALID)
-> MergeMap 'False FieldName (Selection VALID)
-> ReaderT
     [Ref FieldName] m (MergeMap 'False FieldName (Selection VALID))
forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge MergeMap 'False FieldName (Selection VALID)
SelectionSet VALID
m1 MergeMap 'False FieldName (Selection VALID)
SelectionSet VALID
m2 ReaderT
  [Ref FieldName]
  m
  (MergeMap 'False TypeName UnionTag -> SelectionContent s)
-> ReaderT [Ref FieldName] m (MergeMap 'False TypeName UnionTag)
-> HistoryT m (SelectionContent s)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MergeMap 'False TypeName UnionTag
-> MergeMap 'False TypeName UnionTag
-> ReaderT [Ref FieldName] m (MergeMap 'False TypeName UnionTag)
forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge MergeMap 'False TypeName UnionTag
UnionSelection VALID
u1 MergeMap 'False TypeName UnionTag
UnionSelection VALID
u2
  merge SelectionContent s
oldC SelectionContent s
currentC
    | SelectionContent s
oldC SelectionContent s -> SelectionContent s -> Bool
forall a. Eq a => a -> a -> Bool
== SelectionContent s
currentC = SelectionContent s -> HistoryT m (SelectionContent s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure SelectionContent s
oldC
    | Bool
otherwise = do
      [Ref FieldName]
path <- ReaderT [Ref FieldName] m [Ref FieldName]
forall r (m :: * -> *). MonadReader r m => m r
ask
      GQLError -> HistoryT m (SelectionContent s)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        ( Name Any -> GQLError
forall a. Msg a => a -> GQLError
msg (Name Any -> [FieldName] -> Name Any
forall (t1 :: NAME) (t2 :: NAME) (t3 :: NAME).
Name t1 -> [Name t2] -> Name t3
intercalate Name Any
"." ([FieldName] -> Name Any) -> [FieldName] -> Name Any
forall a b. (a -> b) -> a -> b
$ (Ref FieldName -> FieldName) -> [Ref FieldName] -> [FieldName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ref FieldName -> FieldName
forall name. Ref name -> name
refName [Ref FieldName]
path)
            GQLError -> [Position] -> GQLError
forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
`atPositions` (Ref FieldName -> Position) -> [Ref FieldName] -> [Position]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ref FieldName -> Position
forall name. Ref name -> Position
refPosition [Ref FieldName]
path
        )

deriving instance Show (SelectionContent a)

deriving instance Eq (SelectionContent a)

deriving instance Lift (SelectionContent a)

data UnionTag = UnionTag
  { UnionTag -> TypeName
unionTagName :: TypeName,
    UnionTag -> SelectionSet VALID
unionTagSelection :: SelectionSet VALID
  }
  deriving (Int -> UnionTag -> ShowS
[UnionTag] -> ShowS
UnionTag -> String
(Int -> UnionTag -> ShowS)
-> (UnionTag -> String) -> ([UnionTag] -> ShowS) -> Show UnionTag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnionTag] -> ShowS
$cshowList :: [UnionTag] -> ShowS
show :: UnionTag -> String
$cshow :: UnionTag -> String
showsPrec :: Int -> UnionTag -> ShowS
$cshowsPrec :: Int -> UnionTag -> ShowS
Show, UnionTag -> UnionTag -> Bool
(UnionTag -> UnionTag -> Bool)
-> (UnionTag -> UnionTag -> Bool) -> Eq UnionTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnionTag -> UnionTag -> Bool
$c/= :: UnionTag -> UnionTag -> Bool
== :: UnionTag -> UnionTag -> Bool
$c== :: UnionTag -> UnionTag -> Bool
Eq, UnionTag -> Q Exp
UnionTag -> Q (TExp UnionTag)
(UnionTag -> Q Exp)
-> (UnionTag -> Q (TExp UnionTag)) -> Lift UnionTag
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: UnionTag -> Q (TExp UnionTag)
$cliftTyped :: UnionTag -> Q (TExp UnionTag)
lift :: UnionTag -> Q Exp
$clift :: UnionTag -> Q Exp
Lift)

instance KeyOf TypeName UnionTag where
  keyOf :: UnionTag -> TypeName
keyOf = UnionTag -> TypeName
unionTagName

instance RenderGQL UnionTag where
  renderGQL :: UnionTag -> Rendering
renderGQL UnionTag {TypeName
unionTagName :: TypeName
unionTagName :: UnionTag -> TypeName
unionTagName, SelectionSet VALID
unionTagSelection :: SelectionSet VALID
unionTagSelection :: UnionTag -> SelectionSet VALID
unionTagSelection} =
    Rendering
"... on "
      Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> TypeName -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL TypeName
unionTagName
      Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> SelectionSet VALID -> Rendering
renderSelectionSet SelectionSet VALID
unionTagSelection

mergeConflict :: (Monad m, MonadError GQLError m) => GQLError -> HistoryT m a
mergeConflict :: GQLError -> HistoryT m a
mergeConflict GQLError
err = do
  [Ref FieldName]
path <- ReaderT [Ref FieldName] m [Ref FieldName]
forall r (m :: * -> *). MonadReader r m => m r
ask
  [Ref FieldName] -> HistoryT m a
forall (m :: * -> *) a.
(Monad m, MonadError GQLError m) =>
[Ref FieldName] -> HistoryT m a
__mergeConflict [Ref FieldName]
path
  where
    __mergeConflict :: (Monad m, MonadError GQLError m) => [Ref FieldName] -> HistoryT m a
    __mergeConflict :: [Ref FieldName] -> HistoryT m a
__mergeConflict [] = GQLError -> HistoryT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
err
    __mergeConflict refs :: [Ref FieldName]
refs@(Ref FieldName
rootField : [Ref FieldName]
xs) =
      GQLError -> HistoryT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        (GQLError
renderSubfields GQLError -> [Position] -> GQLError
forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
`atPositions` (Ref FieldName -> Position) -> [Ref FieldName] -> [Position]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ref FieldName -> Position
forall name. Ref name -> Position
refPosition [Ref FieldName]
refs GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
err)
      where
        fieldConflicts :: Ref a -> GQLError
fieldConflicts Ref a
ref = a -> GQLError
forall a. Msg a => a -> GQLError
msg (Ref a -> a
forall name. Ref name -> name
refName Ref a
ref) GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" conflict because "
        renderSubfield :: Ref a -> GQLError -> GQLError
renderSubfield Ref a
ref GQLError
txt = GQLError
txt GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"subfields " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> Ref a -> GQLError
forall a. Msg a => Ref a -> GQLError
fieldConflicts Ref a
ref
        renderStart :: GQLError
renderStart = GQLError
"Fields " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> Ref FieldName -> GQLError
forall a. Msg a => Ref a -> GQLError
fieldConflicts Ref FieldName
rootField
        renderSubfields :: GQLError
renderSubfields =
          (Ref FieldName -> GQLError -> GQLError)
-> GQLError -> [Ref FieldName] -> GQLError
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr'
            Ref FieldName -> GQLError -> GQLError
forall a. Msg a => Ref a -> GQLError -> GQLError
renderSubfield
            GQLError
renderStart
            [Ref FieldName]
xs

instance
  ( Monad m,
    MonadError GQLError m
  ) =>
  Merge (HistoryT m) UnionTag
  where
  merge :: UnionTag -> UnionTag -> HistoryT m UnionTag
merge (UnionTag TypeName
oldTag SelectionSet VALID
oldSel) (UnionTag TypeName
_ SelectionSet VALID
currentSel) =
    TypeName -> SelectionSet VALID -> UnionTag
UnionTag TypeName
oldTag (MergeMap 'False FieldName (Selection VALID) -> UnionTag)
-> ReaderT
     [Ref FieldName] m (MergeMap 'False FieldName (Selection VALID))
-> HistoryT m UnionTag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MergeMap 'False FieldName (Selection VALID)
-> MergeMap 'False FieldName (Selection VALID)
-> ReaderT
     [Ref FieldName] m (MergeMap 'False FieldName (Selection VALID))
forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge MergeMap 'False FieldName (Selection VALID)
SelectionSet VALID
oldSel MergeMap 'False FieldName (Selection VALID)
SelectionSet VALID
currentSel

type UnionSelection (s :: Stage) = MergeMap (ALLOW_DUPLICATES s) TypeName UnionTag

type SelectionSet (s :: Stage) = MergeMap (ALLOW_DUPLICATES s) FieldName (Selection s)

splitSystemSelection :: SelectionSet s -> (Maybe (SelectionSet s), Maybe (SelectionSet s))
splitSystemSelection :: SelectionSet s -> (Maybe (SelectionSet s), Maybe (SelectionSet s))
splitSystemSelection = (Selection s -> Bool)
-> SelectionSet s
-> (Maybe (SelectionSet s), Maybe (SelectionSet s))
forall a (dups :: Bool) k.
(a -> Bool)
-> MergeMap dups k a
-> (Maybe (MergeMap dups k a), Maybe (MergeMap dups k a))
partition (Bool -> Bool
not (Bool -> Bool) -> (Selection s -> Bool) -> Selection s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Bool
isNotSystemFieldName (FieldName -> Bool)
-> (Selection s -> FieldName) -> Selection s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selection s -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName)

data Selection (s :: Stage) where
  Selection ::
    { Selection s -> Position
selectionPosition :: Position,
      Selection s -> Maybe FieldName
selectionAlias :: Maybe FieldName,
      Selection s -> FieldName
selectionName :: FieldName,
      Selection s -> Arguments s
selectionArguments :: Arguments s,
      Selection s -> Directives s
selectionDirectives :: Directives s,
      Selection s -> SelectionContent s
selectionContent :: SelectionContent s
    } ->
    Selection s
  InlineFragment :: Fragment RAW -> Selection RAW
  Spread :: Directives RAW -> Ref FragmentName -> Selection RAW

instance RenderGQL (Selection VALID) where
  renderGQL :: Selection VALID -> Rendering
renderGQL
    Selection
      { Maybe FieldName
Directives VALID
Arguments VALID
Position
FieldName
SelectionContent VALID
selectionContent :: SelectionContent VALID
selectionDirectives :: Directives VALID
selectionArguments :: Arguments VALID
selectionName :: FieldName
selectionAlias :: Maybe FieldName
selectionPosition :: Position
selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionDirectives :: forall (s :: Stage). Selection s -> Directives s
selectionArguments :: forall (s :: Stage). Selection s -> Arguments s
selectionAlias :: forall (s :: Stage). Selection s -> Maybe FieldName
selectionPosition :: forall (s :: Stage). Selection s -> Position
selectionName :: forall (s :: Stage). Selection s -> FieldName
..
      } =
      FieldName -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL (FieldName -> Maybe FieldName -> FieldName
forall a. a -> Maybe a -> a
fromMaybe FieldName
selectionName Maybe FieldName
selectionAlias)
        Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Arguments VALID -> Rendering
forall (s :: Stage). Arguments s -> Rendering
renderArgumentValues Arguments VALID
selectionArguments
        Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Directives VALID -> Rendering
forall (s :: Stage). Directives s -> Rendering
renderDirectives Directives VALID
selectionDirectives
        Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> SelectionContent VALID -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL SelectionContent VALID
selectionContent

instance KeyOf FieldName (Selection s) where
  keyOf :: Selection s -> FieldName
keyOf
    Selection
      { FieldName
selectionName :: FieldName
selectionName :: forall (s :: Stage). Selection s -> FieldName
selectionName,
        Maybe FieldName
selectionAlias :: Maybe FieldName
selectionAlias :: forall (s :: Stage). Selection s -> Maybe FieldName
selectionAlias
      } = FieldName -> Maybe FieldName -> FieldName
forall a. a -> Maybe a -> a
fromMaybe FieldName
selectionName Maybe FieldName
selectionAlias
  keyOf Selection s
_ = FieldName
""

useDifferentAliases :: GQLError
useDifferentAliases :: GQLError
useDifferentAliases =
  GQLError
"Use different aliases on the "
    GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"fields to fetch both if this was intentional."

instance
  ( Monad m,
    MonadError GQLError m,
    Merge (HistoryT m) (SelectionSet s)
  ) =>
  Merge (HistoryT m) (Selection s)
  where
  merge :: Selection s -> Selection s -> HistoryT m (Selection s)
merge = Selection s -> Selection s -> HistoryT m (Selection s)
forall (m :: * -> *) (s :: Stage).
(Monad m, MonadError GQLError m,
 Merge (HistoryT m) (SelectionSet s)) =>
Selection s -> Selection s -> HistoryT m (Selection s)
mergeSelection

mergeSelection ::
  ( Monad m,
    MonadError GQLError m,
    Merge (HistoryT m) (SelectionSet s)
  ) =>
  Selection s ->
  Selection s ->
  HistoryT m (Selection s)
mergeSelection :: Selection s -> Selection s -> HistoryT m (Selection s)
mergeSelection
  old :: Selection s
old@Selection {selectionPosition :: forall (s :: Stage). Selection s -> Position
selectionPosition = Position
pos1}
  current :: Selection s
current@Selection {selectionPosition :: forall (s :: Stage). Selection s -> Position
selectionPosition = Position
pos2} =
    do
      FieldName
selectionName <- [Position] -> Selection s -> Selection s -> HistoryT m FieldName
forall (m :: * -> *) (t :: * -> *) (s1 :: Stage) (s2 :: Stage).
(Monad m, MonadError GQLError m, Foldable t) =>
t Position -> Selection s1 -> Selection s2 -> HistoryT m FieldName
mergeName [Position
pos1, Position
pos2] Selection s
old Selection s
current
      Ref FieldName
-> HistoryT m (Selection s) -> HistoryT m (Selection s)
forall a1 (m :: * -> *) a2.
MonadReader [a1] m =>
a1 -> m a2 -> m a2
addPath (FieldName -> Position -> Ref FieldName
forall name. name -> Position -> Ref name
Ref FieldName
selectionName Position
pos1) (HistoryT m (Selection s) -> HistoryT m (Selection s))
-> HistoryT m (Selection s) -> HistoryT m (Selection s)
forall a b. (a -> b) -> a -> b
$ do
        Arguments s
selectionArguments <- ReaderT [Ref FieldName] m (Arguments s)
mergeArguments
        SelectionContent s
selectionContent <- SelectionContent s
-> SelectionContent s
-> ReaderT [Ref FieldName] m (SelectionContent s)
forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge (Selection s -> SelectionContent s
forall (s :: Stage). Selection s -> SelectionContent s
selectionContent Selection s
old) (Selection s -> SelectionContent s
forall (s :: Stage). Selection s -> SelectionContent s
selectionContent Selection s
current)
        Directives s
dirs <- Selection s -> Directives s
forall (s :: Stage). Selection s -> Directives s
selectionDirectives Selection s
old Directives s
-> Directives s -> ReaderT [Ref FieldName] m (Directives s)
forall (m :: * -> *) a.
(Merge (HistoryT m) a, Monad m) =>
a -> a -> m a
<:> Selection s -> Directives s
forall (s :: Stage). Selection s -> Directives s
selectionDirectives Selection s
current
        Selection s -> HistoryT m (Selection s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Selection s -> HistoryT m (Selection s))
-> Selection s -> HistoryT m (Selection s)
forall a b. (a -> b) -> a -> b
$
          Selection :: forall (s :: Stage).
Position
-> Maybe FieldName
-> FieldName
-> Arguments s
-> Directives s
-> SelectionContent s
-> Selection s
Selection
            { selectionAlias :: Maybe FieldName
selectionAlias = Maybe FieldName
mergeAlias,
              selectionPosition :: Position
selectionPosition = Position
pos1,
              selectionDirectives :: Directives s
selectionDirectives = Directives s
dirs,
              Arguments s
FieldName
SelectionContent s
selectionContent :: SelectionContent s
selectionArguments :: Arguments s
selectionName :: FieldName
selectionContent :: SelectionContent s
selectionArguments :: Arguments s
selectionName :: FieldName
..
            }
    where
      mergeAlias :: Maybe FieldName
mergeAlias
        | (Selection s -> Bool) -> [Selection s] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe FieldName -> Bool
forall a. Maybe a -> Bool
isJust (Maybe FieldName -> Bool)
-> (Selection s -> Maybe FieldName) -> Selection s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selection s -> Maybe FieldName
forall (s :: Stage). Selection s -> Maybe FieldName
selectionAlias) [Selection s
old, Selection s
current] = Selection s -> Maybe FieldName
forall (s :: Stage). Selection s -> Maybe FieldName
selectionAlias Selection s
old
        | Bool
otherwise = Maybe FieldName
forall a. Maybe a
Nothing
      --- arguments must be equal
      mergeArguments :: ReaderT [Ref FieldName] m (Arguments s)
mergeArguments
        | Selection s -> Arguments s
forall (s :: Stage). Selection s -> Arguments s
selectionArguments Selection s
old Arguments s -> Arguments s -> Bool
forall a. Eq a => a -> a -> Bool
== Selection s -> Arguments s
forall (s :: Stage). Selection s -> Arguments s
selectionArguments Selection s
current = Arguments s -> ReaderT [Ref FieldName] m (Arguments s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Arguments s -> ReaderT [Ref FieldName] m (Arguments s))
-> Arguments s -> ReaderT [Ref FieldName] m (Arguments s)
forall a b. (a -> b) -> a -> b
$ Selection s -> Arguments s
forall (s :: Stage). Selection s -> Arguments s
selectionArguments Selection s
current
        | Bool
otherwise =
          GQLError -> ReaderT [Ref FieldName] m (Arguments s)
forall (m :: * -> *) a.
(Monad m, MonadError GQLError m) =>
GQLError -> HistoryT m a
mergeConflict (GQLError -> ReaderT [Ref FieldName] m (Arguments s))
-> GQLError -> ReaderT [Ref FieldName] m (Arguments s)
forall a b. (a -> b) -> a -> b
$
            (GQLError
"they have differing arguments. " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
useDifferentAliases)
              GQLError -> [Position] -> GQLError
forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
`atPositions` [Position
pos1, Position
pos2]
mergeSelection Selection s
x Selection s
y = GQLError -> HistoryT m (Selection s)
forall (m :: * -> *) a.
(Monad m, MonadError GQLError m) =>
GQLError -> HistoryT m a
mergeConflict (GQLError
"INTERNAL: can't merge. " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> Selection s -> GQLError
forall a. Show a => a -> GQLError
msgValue Selection s
x GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> Selection s -> GQLError
forall a. Show a => a -> GQLError
msgValue Selection s
y GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
useDifferentAliases)

msgValue :: Show a => a -> GQLError
msgValue :: a -> GQLError
msgValue = String -> GQLError
forall a. Msg a => a -> GQLError
msg (String -> GQLError) -> (a -> String) -> a -> GQLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-- fails if alias matches but name not:
--   { user1: user
--     user1: product
--   }
mergeName ::
  (Monad m, MonadError GQLError m, Foldable t) =>
  t Position ->
  Selection s1 ->
  Selection s2 ->
  HistoryT m FieldName
mergeName :: t Position -> Selection s1 -> Selection s2 -> HistoryT m FieldName
mergeName t Position
pos Selection s1
old Selection s2
current
  | Selection s1 -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName Selection s1
old FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
== Selection s2 -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName Selection s2
current = FieldName -> HistoryT m FieldName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> HistoryT m FieldName)
-> FieldName -> HistoryT m FieldName
forall a b. (a -> b) -> a -> b
$ Selection s2 -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName Selection s2
current
  | Bool
otherwise =
    GQLError -> HistoryT m FieldName
forall (m :: * -> *) a.
(Monad m, MonadError GQLError m) =>
GQLError -> HistoryT m a
mergeConflict (GQLError -> HistoryT m FieldName)
-> GQLError -> HistoryT m FieldName
forall a b. (a -> b) -> a -> b
$
      ( FieldName -> GQLError
forall a. Msg a => a -> GQLError
msg (Selection s1 -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName Selection s1
old)
          GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" and "
          GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> FieldName -> GQLError
forall a. Msg a => a -> GQLError
msg (Selection s2 -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName Selection s2
current)
          GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" are different fields. "
          GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
useDifferentAliases
      )
        GQLError -> t Position -> GQLError
forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
`atPositions` t Position
pos

deriving instance Show (Selection a)

deriving instance Lift (Selection a)

deriving instance Eq (Selection a)

type DefaultValue = Maybe ResolvedValue

data Operation (s :: Stage) = Operation
  { Operation s -> Position
operationPosition :: Position,
    Operation s -> OperationType
operationType :: OperationType,
    Operation s -> Maybe FieldName
operationName :: Maybe FieldName,
    Operation s -> VariableDefinitions s
operationArguments :: VariableDefinitions s,
    Operation s -> Directives s
operationDirectives :: Directives s,
    Operation s -> SelectionSet s
operationSelection :: SelectionSet s
  }
  deriving (Int -> Operation s -> ShowS
[Operation s] -> ShowS
Operation s -> String
(Int -> Operation s -> ShowS)
-> (Operation s -> String)
-> ([Operation s] -> ShowS)
-> Show (Operation s)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: Stage). Int -> Operation s -> ShowS
forall (s :: Stage). [Operation s] -> ShowS
forall (s :: Stage). Operation s -> String
showList :: [Operation s] -> ShowS
$cshowList :: forall (s :: Stage). [Operation s] -> ShowS
show :: Operation s -> String
$cshow :: forall (s :: Stage). Operation s -> String
showsPrec :: Int -> Operation s -> ShowS
$cshowsPrec :: forall (s :: Stage). Int -> Operation s -> ShowS
Show, Operation s -> Q Exp
Operation s -> Q (TExp (Operation s))
(Operation s -> Q Exp)
-> (Operation s -> Q (TExp (Operation s))) -> Lift (Operation s)
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
forall (s :: Stage). Operation s -> Q Exp
forall (s :: Stage). Operation s -> Q (TExp (Operation s))
liftTyped :: Operation s -> Q (TExp (Operation s))
$cliftTyped :: forall (s :: Stage). Operation s -> Q (TExp (Operation s))
lift :: Operation s -> Q Exp
$clift :: forall (s :: Stage). Operation s -> Q Exp
Lift)

instance RenderGQL (Operation VALID) where
  renderGQL :: Operation VALID -> Rendering
renderGQL
    Operation
      { Maybe FieldName
operationName :: Maybe FieldName
operationName :: forall (s :: Stage). Operation s -> Maybe FieldName
operationName,
        OperationType
operationType :: OperationType
operationType :: forall (s :: Stage). Operation s -> OperationType
operationType,
        Directives VALID
operationDirectives :: Directives VALID
operationDirectives :: forall (s :: Stage). Operation s -> Directives s
operationDirectives,
        SelectionSet VALID
operationSelection :: SelectionSet VALID
operationSelection :: forall (s :: Stage). Operation s -> SelectionSet s
operationSelection
      } =
      OperationType -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL OperationType
operationType
        Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Rendering
-> (FieldName -> Rendering) -> Maybe FieldName -> Rendering
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Rendering
"" ((Rendering
space Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<>) (Rendering -> Rendering)
-> (FieldName -> Rendering) -> FieldName -> Rendering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL) Maybe FieldName
operationName
        Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Directives VALID -> Rendering
forall (s :: Stage). Directives s -> Rendering
renderDirectives Directives VALID
operationDirectives
        Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> SelectionSet VALID -> Rendering
renderSelectionSet SelectionSet VALID
operationSelection
        Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Rendering
newline

getOperationName :: Maybe FieldName -> TypeName
getOperationName :: Maybe FieldName -> TypeName
getOperationName = TypeName -> (FieldName -> TypeName) -> Maybe FieldName -> TypeName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeName
"AnonymousOperation" FieldName -> TypeName
coerce

getOperationDataType :: MonadError GQLError m => Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID)
getOperationDataType :: Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID)
getOperationDataType Operation {operationType :: forall (s :: Stage). Operation s -> OperationType
operationType = OperationType
Query} Schema VALID
lib = TypeDefinition OBJECT VALID -> m (TypeDefinition OBJECT VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema VALID -> TypeDefinition OBJECT VALID
forall (s :: Stage). Schema s -> TypeDefinition OBJECT s
query Schema VALID
lib)
getOperationDataType Operation {operationType :: forall (s :: Stage). Operation s -> OperationType
operationType = OperationType
Mutation, Position
operationPosition :: Position
operationPosition :: forall (s :: Stage). Operation s -> Position
operationPosition} Schema VALID
lib =
  m (TypeDefinition OBJECT VALID)
-> (TypeDefinition OBJECT VALID -> m (TypeDefinition OBJECT VALID))
-> Maybe (TypeDefinition OBJECT VALID)
-> m (TypeDefinition OBJECT VALID)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GQLError -> m (TypeDefinition OBJECT VALID)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> m (TypeDefinition OBJECT VALID))
-> GQLError -> m (TypeDefinition OBJECT VALID)
forall a b. (a -> b) -> a -> b
$ Position -> GQLError
mutationIsNotDefined Position
operationPosition) TypeDefinition OBJECT VALID -> m (TypeDefinition OBJECT VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema VALID -> Maybe (TypeDefinition OBJECT VALID)
forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
mutation Schema VALID
lib)
getOperationDataType Operation {operationType :: forall (s :: Stage). Operation s -> OperationType
operationType = OperationType
Subscription, Position
operationPosition :: Position
operationPosition :: forall (s :: Stage). Operation s -> Position
operationPosition} Schema VALID
lib =
  m (TypeDefinition OBJECT VALID)
-> (TypeDefinition OBJECT VALID -> m (TypeDefinition OBJECT VALID))
-> Maybe (TypeDefinition OBJECT VALID)
-> m (TypeDefinition OBJECT VALID)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GQLError -> m (TypeDefinition OBJECT VALID)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> m (TypeDefinition OBJECT VALID))
-> GQLError -> m (TypeDefinition OBJECT VALID)
forall a b. (a -> b) -> a -> b
$ Position -> GQLError
subscriptionIsNotDefined Position
operationPosition) TypeDefinition OBJECT VALID -> m (TypeDefinition OBJECT VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema VALID -> Maybe (TypeDefinition OBJECT VALID)
forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
subscription Schema VALID
lib)