{-# 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,
  )
where

import Data.Morpheus.Error.NameCollision
  ( NameCollision (..),
  )
import Data.Morpheus.Error.Operation
  ( mutationIsNotDefined,
    subscriptionIsNotDefined,
  )
import Data.Morpheus.Ext.MergeSet
  ( MergeSet,
  )
import Data.Morpheus.Ext.OrdMap
  ( OrdMap,
  )
import Data.Morpheus.Ext.SemigroupM (SemigroupM (..))
import Data.Morpheus.Internal.Utils
  ( Failure (..),
    KeyOf (..),
    elems,
  )
import Data.Morpheus.Rendering.RenderGQL
  ( RenderGQL (..),
    Rendering,
    newline,
    renderObject,
    space,
  )
import Data.Morpheus.Types.Internal.AST.Base
  ( FieldName,
    Message,
    Msg (..),
    OperationType (..),
    Position,
    Ref (..),
    TypeName (..),
    ValidationError (..),
    ValidationErrors,
    intercalateName,
    msg,
    msgValidation,
    readName,
  )
import Data.Morpheus.Types.Internal.AST.Fields
  ( Arguments,
    Directives,
    renderArgumentValues,
    renderDirectives,
  )
import Data.Morpheus.Types.Internal.AST.Stage
  ( 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

data Fragment (stage :: Stage) = Fragment
  { Fragment stage -> FieldName
fragmentName :: FieldName,
    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 (Fragment s) where
  nameCollision :: Fragment s -> ValidationError
nameCollision Fragment {FieldName
fragmentName :: FieldName
fragmentName :: forall (stage :: Stage). Fragment stage -> FieldName
fragmentName, Position
fragmentPosition :: Position
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentPosition} =
    Message -> [Position] -> ValidationError
ValidationError
      (Message
"There can be only one fragment named " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg FieldName
fragmentName Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
".")
      [Position
fragmentPosition]

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

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

data SelectionContent (s :: Stage) where
  SelectionField :: SelectionContent s
  SelectionSet :: SelectionSet s -> SelectionContent s
  UnionSelection :: 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)
-> (SelectionSet VALID -> [Selection VALID])
-> SelectionSet VALID
-> Rendering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SelectionSet VALID -> [Selection VALID]
forall a coll. Elems a coll => coll -> [a]
elems

instance RenderGQL (SelectionContent VALID) where
  render :: SelectionContent VALID -> Rendering
render SelectionContent VALID
SelectionField = Rendering
""
  render (SelectionSet SelectionSet VALID
selSet) = SelectionSet VALID -> Rendering
renderSelectionSet SelectionSet VALID
selSet
  render (UnionSelection UnionSelection VALID
unionSets) = [UnionTag] -> Rendering
forall a. RenderGQL a => [a] -> Rendering
renderObject (UnionSelection VALID -> [UnionTag]
forall a coll. Elems a coll => coll -> [a]
elems UnionSelection VALID
unionSets)

instance
  ( Monad m,
    Failure ValidationErrors m,
    SemigroupM m (SelectionSet s)
  ) =>
  SemigroupM m (SelectionContent s)
  where
  mergeM :: [Ref]
-> SelectionContent s
-> SelectionContent s
-> m (SelectionContent s)
mergeM [Ref]
path (SelectionSet SelectionSet s
s1) (SelectionSet SelectionSet s
s2) = SelectionSet s -> SelectionContent s
forall (s :: Stage). SelectionSet s -> SelectionContent s
SelectionSet (SelectionSet s -> SelectionContent s)
-> m (SelectionSet s) -> m (SelectionContent s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ref] -> SelectionSet s -> SelectionSet s -> m (SelectionSet s)
forall (m :: * -> *) a. SemigroupM m a => [Ref] -> a -> a -> m a
mergeM [Ref]
path SelectionSet s
s1 SelectionSet s
s2
  mergeM [Ref]
path (UnionSelection UnionSelection VALID
u1) (UnionSelection UnionSelection VALID
u2) = UnionSelection VALID -> SelectionContent VALID
UnionSelection (UnionSelection VALID -> SelectionContent VALID)
-> m (UnionSelection VALID) -> m (SelectionContent VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ref]
-> UnionSelection VALID
-> UnionSelection VALID
-> m (UnionSelection VALID)
forall (m :: * -> *) a. SemigroupM m a => [Ref] -> a -> a -> m a
mergeM [Ref]
path UnionSelection VALID
u1 UnionSelection VALID
u2
  mergeM [Ref]
path 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 -> m (SelectionContent s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure SelectionContent s
oldC
    | Bool
otherwise =
      ValidationErrors -> m (SelectionContent s)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure
        [ ValidationError :: Message -> [Position] -> ValidationError
ValidationError
            { validationMessage :: Message
validationMessage = FieldName -> Message
forall a. Msg a => a -> Message
msg (FieldName -> [FieldName] -> FieldName
intercalateName FieldName
"." ([FieldName] -> FieldName) -> [FieldName] -> FieldName
forall a b. (a -> b) -> a -> b
$ (Ref -> FieldName) -> [Ref] -> [FieldName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ref -> FieldName
refName [Ref]
path),
              validationLocations :: [Position]
validationLocations = (Ref -> Position) -> [Ref] -> [Position]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ref -> Position
refPosition [Ref]
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
  render :: UnionTag -> Rendering
render 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
render TypeName
unionTagName
      Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> SelectionSet VALID -> Rendering
renderSelectionSet SelectionSet VALID
unionTagSelection

mergeConflict :: [Ref] -> ValidationError -> ValidationErrors
mergeConflict :: [Ref] -> ValidationError -> ValidationErrors
mergeConflict [] ValidationError
err = [ValidationError
err]
mergeConflict refs :: [Ref]
refs@(Ref
rootField : [Ref]
xs) ValidationError
err =
  [ ValidationError :: Message -> [Position] -> ValidationError
ValidationError
      { validationMessage :: Message
validationMessage = Message
renderSubfields Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> ValidationError -> Message
validationMessage ValidationError
err,
        validationLocations :: [Position]
validationLocations = (Ref -> Position) -> [Ref] -> [Position]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ref -> Position
refPosition [Ref]
refs [Position] -> [Position] -> [Position]
forall a. Semigroup a => a -> a -> a
<> ValidationError -> [Position]
validationLocations ValidationError
err
      }
  ]
  where
    fieldConflicts :: Ref -> Message
fieldConflicts Ref
ref = FieldName -> Message
forall a. Msg a => a -> Message
msg (Ref -> FieldName
refName Ref
ref) Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
" conflict because "
    renderSubfield :: Ref -> Message -> Message
renderSubfield Ref
ref Message
txt = Message
txt Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
"subfields " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Ref -> Message
fieldConflicts Ref
ref
    renderStart :: Message
renderStart = Message
"Fields " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Ref -> Message
fieldConflicts Ref
rootField
    renderSubfields :: Message
renderSubfields =
      (Ref -> Message -> Message) -> Message -> [Ref] -> Message
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        Ref -> Message -> Message
renderSubfield
        Message
renderStart
        [Ref]
xs

instance (Monad m, Failure ValidationErrors m) => SemigroupM m UnionTag where
  mergeM :: [Ref] -> UnionTag -> UnionTag -> m UnionTag
mergeM [Ref]
path (UnionTag TypeName
oldTag SelectionSet VALID
oldSel) (UnionTag TypeName
_ SelectionSet VALID
currentSel) =
    TypeName -> SelectionSet VALID -> UnionTag
UnionTag TypeName
oldTag (SelectionSet VALID -> UnionTag)
-> m (SelectionSet VALID) -> m UnionTag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ref]
-> SelectionSet VALID
-> SelectionSet VALID
-> m (SelectionSet VALID)
forall (m :: * -> *) a. SemigroupM m a => [Ref] -> a -> a -> m a
mergeM [Ref]
path SelectionSet VALID
oldSel SelectionSet VALID
currentSel

type UnionSelection (s :: Stage) = MergeSet s TypeName UnionTag

type SelectionSet (s :: Stage) = MergeSet s FieldName (Selection s)

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 -> Selection RAW

instance RenderGQL (Selection VALID) where
  render :: Selection VALID -> Rendering
render
    Selection
      { Directives VALID
Maybe FieldName
Position
FieldName
Arguments VALID
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
selectionName :: forall (s :: Stage). Selection s -> FieldName
selectionAlias :: forall (s :: Stage). Selection s -> Maybe FieldName
selectionPosition :: forall (s :: Stage). Selection s -> Position
..
      } =
      FieldName -> Rendering
forall a. RenderGQL a => a -> Rendering
render (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
render 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 :: Message
useDifferentAliases :: Message
useDifferentAliases =
  Message
"Use different aliases on the "
    Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
"fields to fetch both if this was intentional."

instance
  ( Monad m,
    SemigroupM m (SelectionSet a),
    Failure ValidationErrors m
  ) =>
  SemigroupM m (Selection a)
  where
  mergeM :: [Ref] -> Selection a -> Selection a -> m (Selection a)
mergeM
    [Ref]
path
    old :: Selection a
old@Selection {selectionPosition :: forall (s :: Stage). Selection s -> Position
selectionPosition = Position
pos1}
    current :: Selection a
current@Selection {selectionPosition :: forall (s :: Stage). Selection s -> Position
selectionPosition = Position
pos2} =
      do
        FieldName
selectionName <- m FieldName
mergeName
        let currentPath :: [Ref]
currentPath = [Ref]
path [Ref] -> [Ref] -> [Ref]
forall a. Semigroup a => a -> a -> a
<> [FieldName -> Position -> Ref
Ref FieldName
selectionName Position
pos1]
        Arguments a
selectionArguments <- [Ref] -> m (Arguments a)
mergeArguments [Ref]
currentPath
        SelectionContent a
selectionContent <- [Ref]
-> SelectionContent a
-> SelectionContent a
-> m (SelectionContent a)
forall (m :: * -> *) a. SemigroupM m a => [Ref] -> a -> a -> m a
mergeM [Ref]
currentPath (Selection a -> SelectionContent a
forall (s :: Stage). Selection s -> SelectionContent s
selectionContent Selection a
old) (Selection a -> SelectionContent a
forall (s :: Stage). Selection s -> SelectionContent s
selectionContent Selection a
current)
        Selection a -> m (Selection a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Selection a -> m (Selection a)) -> Selection a -> m (Selection a)
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 a
selectionDirectives = Selection a -> Directives a
forall (s :: Stage). Selection s -> Directives s
selectionDirectives Selection a
old Directives a -> Directives a -> Directives a
forall a. Semigroup a => a -> a -> a
<> Selection a -> Directives a
forall (s :: Stage). Selection s -> Directives s
selectionDirectives Selection a
current,
              FieldName
Arguments a
SelectionContent a
selectionContent :: SelectionContent a
selectionArguments :: Arguments a
selectionName :: FieldName
selectionContent :: SelectionContent a
selectionArguments :: Arguments a
selectionName :: FieldName
..
            }
      where
        -- passes if:

        --     user1: user
        --   }
        -- fails if:

        --     user1: product
        --   }
        mergeName :: m FieldName
mergeName
          | Selection a -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName Selection a
old FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
== Selection a -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName Selection a
current = FieldName -> m FieldName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> m FieldName) -> FieldName -> m FieldName
forall a b. (a -> b) -> a -> b
$ Selection a -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName Selection a
current
          | Bool
otherwise =
            ValidationErrors -> m FieldName
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (ValidationErrors -> m FieldName)
-> ValidationErrors -> m FieldName
forall a b. (a -> b) -> a -> b
$ [Ref] -> ValidationError -> ValidationErrors
mergeConflict [Ref]
path (ValidationError -> ValidationErrors)
-> ValidationError -> ValidationErrors
forall a b. (a -> b) -> a -> b
$
              ValidationError :: Message -> [Position] -> ValidationError
ValidationError
                { validationMessage :: Message
validationMessage =
                    Message
"" Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg (Selection a -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName Selection a
old) Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
" and " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg (Selection a -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName Selection a
current)
                      Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
" are different fields. "
                      Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
useDifferentAliases,
                  validationLocations :: [Position]
validationLocations = [Position
pos1, Position
pos2]
                }
        ---------------------
        -- alias name is relevant only if they collide by allies like:
        --   { user1: user
        --     user1: user
        --   }
        mergeAlias :: Maybe FieldName
mergeAlias
          | (Selection a -> Bool) -> [Selection a] -> 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 a -> Maybe FieldName) -> Selection a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selection a -> Maybe FieldName
forall (s :: Stage). Selection s -> Maybe FieldName
selectionAlias) [Selection a
old, Selection a
current] = Selection a -> Maybe FieldName
forall (s :: Stage). Selection s -> Maybe FieldName
selectionAlias Selection a
old
          | Bool
otherwise = Maybe FieldName
forall a. Maybe a
Nothing
        --- arguments must be equal
        mergeArguments :: [Ref] -> m (Arguments a)
mergeArguments [Ref]
currentPath
          | Selection a -> Arguments a
forall (s :: Stage). Selection s -> Arguments s
selectionArguments Selection a
old Arguments a -> Arguments a -> Bool
forall a. Eq a => a -> a -> Bool
== Selection a -> Arguments a
forall (s :: Stage). Selection s -> Arguments s
selectionArguments Selection a
current = Arguments a -> m (Arguments a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Arguments a -> m (Arguments a)) -> Arguments a -> m (Arguments a)
forall a b. (a -> b) -> a -> b
$ Selection a -> Arguments a
forall (s :: Stage). Selection s -> Arguments s
selectionArguments Selection a
current
          | Bool
otherwise =
            ValidationErrors -> m (Arguments a)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (ValidationErrors -> m (Arguments a))
-> ValidationErrors -> m (Arguments a)
forall a b. (a -> b) -> a -> b
$ [Ref] -> ValidationError -> ValidationErrors
mergeConflict [Ref]
currentPath (ValidationError -> ValidationErrors)
-> ValidationError -> ValidationErrors
forall a b. (a -> b) -> a -> b
$
              ValidationError :: Message -> [Position] -> ValidationError
ValidationError
                { validationMessage :: Message
validationMessage = Message
"they have differing arguments. " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
useDifferentAliases,
                  validationLocations :: [Position]
validationLocations = [Position
pos1, Position
pos2]
                }
  mergeM [Ref]
path Selection a
_ Selection a
_ =
    ValidationErrors -> m (Selection a)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (ValidationErrors -> m (Selection a))
-> ValidationErrors -> m (Selection a)
forall a b. (a -> b) -> a -> b
$
      [Ref] -> ValidationError -> ValidationErrors
mergeConflict
        [Ref]
path
        (ValidationError
"INTERNAL: can't merge. " ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> Message -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation Message
useDifferentAliases :: ValidationError)

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
  render :: Operation VALID -> Rendering
render
    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
render 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
render) 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" (Text -> TypeName
TypeName (Text -> TypeName) -> (FieldName -> Text) -> FieldName -> TypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Text
readName)

getOperationDataType :: Failure ValidationError 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 (ValidationError -> m (TypeDefinition OBJECT VALID)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (ValidationError -> m (TypeDefinition OBJECT VALID))
-> ValidationError -> m (TypeDefinition OBJECT VALID)
forall a b. (a -> b) -> a -> b
$ Position -> ValidationError
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 (ValidationError -> m (TypeDefinition OBJECT VALID)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (ValidationError -> m (TypeDefinition OBJECT VALID))
-> ValidationError -> m (TypeDefinition OBJECT VALID)
forall a b. (a -> b) -> a -> b
$ Position -> ValidationError
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)