Skip to content

Commit 693d0b3

Browse files
committed
Revert Node as instance of HasName to getNodeName
Majority of code change occurred in Validations.hs because the StateT monad needed to operate on a state of type `Set (Maybe Name)` instead of `Set Name`. This was complicated by the fact that fragments use a raw `Name`, not the wrapped `Maybe Name`. Lifted `Name` with `pure Name` in all places it needed to be used inside StateT`s state. Internal/Syntax/AST.hs: * Clean imports * Change type of Node to replace Name with (Maybe Name) Internal/Syntax/Parser.hs: * Make nameParser optional Internal/Syntax/Encoder.hs: * Self explanatory. Internal/Validations.hs: * Rename variables to clearly reflect that they carry a `Maybe Name` somewhere within rather than a `Name`. * Change `StateT`'s state type to `Set (Maybe Name)` * Wrap any `Name` type that needs to go into `StateT`'s state. Change tests accordingly.
1 parent 2bf5c01 commit 693d0b3

File tree

9 files changed

+64
-51
lines changed

9 files changed

+64
-51
lines changed

docs/source/tutorial/tutorial.cabal

+7-5
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,8 @@
1-
-- This file has been generated from package.yaml by hpack version 0.15.0.
1+
-- This file has been generated from package.yaml by hpack version 0.20.0.
22
--
33
-- see: https://github.com/sol/hpack
4+
--
5+
-- hash: b3da6c729f0fa19c9ad82cb7e45f616850463bcc1654b9cd4797e34f6685ebd8
46

57
name: tutorial
68
version: 0.0.1
@@ -18,11 +20,11 @@ library
1820
other-modules:
1921
Paths_tutorial
2022
build-depends:
21-
base >= 4.9 && < 5
22-
, protolude
23+
aeson
24+
, base >=4.9 && <5
2325
, graphql-api
26+
, markdown-unlit >=0.4
27+
, protolude
2428
, random
25-
, markdown-unlit >= 0.4
26-
, aeson
2729
default-language: Haskell2010
2830
ghc-options: -Wall -pgmL markdown-unlit

graphql-wai/graphql-wai.cabal

+18-12
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,8 @@
1-
-- This file has been generated from package.yaml by hpack version 0.15.0.
1+
-- This file has been generated from package.yaml by hpack version 0.20.0.
22
--
33
-- see: https://github.com/sol/hpack
4+
--
5+
-- hash: 12d030d800c1c036c89a9464dd8de8b05f9f6dc28e0faae9d2b105b2b120460e
46

57
name: graphql-wai
68
version: 0.1.0
@@ -22,15 +24,17 @@ library
2224
default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications
2325
ghc-options: -Wall -fno-warn-redundant-constraints -Werror
2426
build-depends:
25-
base >= 4.9 && < 5
26-
, protolude
27+
aeson
28+
, base >=4.9 && <5
2729
, exceptions
28-
, wai
29-
, http-types
3030
, graphql-api
31-
, aeson
31+
, http-types
32+
, protolude
33+
, wai
3234
exposed-modules:
3335
GraphQL.Wai
36+
other-modules:
37+
Paths_graphql_wai
3438
default-language: Haskell2010
3539

3640
test-suite wai-tests
@@ -41,13 +45,15 @@ test-suite wai-tests
4145
default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications
4246
ghc-options: -Wall -fno-warn-redundant-constraints -Werror
4347
build-depends:
44-
base >= 4.9 && < 5
45-
, protolude
48+
aeson
49+
, base >=4.9 && <5
4650
, exceptions
47-
, wai
48-
, http-types
4951
, graphql-api
50-
, aeson
51-
, wai-extra
5252
, graphql-wai
53+
, http-types
54+
, protolude
55+
, wai
56+
, wai-extra
57+
other-modules:
58+
Paths_graphql_wai
5359
default-language: Haskell2010

src/GraphQL/Internal/Execution.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -51,7 +51,7 @@ import GraphQL.Internal.Validation
5151
-- * Return {operation}.
5252
getOperation :: QueryDocument value -> Maybe Name -> Either ExecutionError (Operation value)
5353
getOperation (LoneAnonymousOperation op) Nothing = pure op
54-
getOperation (MultipleOperations ops) (Just name) = note (NoSuchOperation name) (Map.lookup name ops)
54+
getOperation (MultipleOperations ops) (Just name) = note (NoSuchOperation name) (Map.lookup (pure name) ops)
5555
getOperation (MultipleOperations ops) Nothing =
5656
case toList ops of
5757
[op] -> pure op

src/GraphQL/Internal/Syntax/AST.hs

+6-5
Original file line numberDiff line numberDiff line change
@@ -49,10 +49,10 @@ module GraphQL.Internal.Syntax.AST
4949
import Protolude
5050

5151
--import Data.String (IsString(..))
52-
import Test.QuickCheck (Arbitrary(..), elements, listOf, oneof)
52+
import Test.QuickCheck (Arbitrary(..), listOf, oneof)
5353

5454
import GraphQL.Internal.Arbitrary (arbitraryText)
55-
import GraphQL.Internal.Name (HasName(getName), Name(unName, Name), unsafeMakeName)
55+
import GraphQL.Internal.Name (Name)
5656

5757
-- * Documents
5858

@@ -76,11 +76,12 @@ data OperationDefinition
7676
| AnonymousQuery SelectionSet
7777
deriving (Eq,Show)
7878

79-
data Node = Node Name [VariableDefinition] [Directive] SelectionSet
79+
data Node = Node (Maybe Name) [VariableDefinition] [Directive] SelectionSet
8080
deriving (Eq,Show)
8181

82-
instance HasName Node where
83-
getName (Node name _ _ _) = name
82+
--
83+
getNodeName :: Node -> Maybe Name
84+
getNodeName (Node maybeName _ _ _) = maybeName
8485

8586
data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
8687
deriving (Eq,Show)

src/GraphQL/Internal/Syntax/Encoder.hs

+5-1
Original file line numberDiff line numberDiff line change
@@ -30,11 +30,15 @@ operationDefinition (AST.Mutation n) = "mutation " <> node n
3030
operationDefinition (AST.AnonymousQuery ss) = selectionSet ss
3131

3232
node :: AST.Node -> Text
33-
node (AST.Node name vds ds ss) =
33+
node (AST.Node (Just name) vds ds ss) =
3434
unName name
3535
<> optempty variableDefinitions vds
3636
<> optempty directives ds
3737
<> selectionSet ss
38+
node (AST.Node Nothing vds ds ss) =
39+
optempty variableDefinitions vds
40+
<> optempty directives ds
41+
<> selectionSet ss
3842

3943
variableDefinitions :: [AST.VariableDefinition] -> Text
4044
variableDefinitions = parensCommas variableDefinition

src/GraphQL/Internal/Syntax/Parser.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -52,7 +52,7 @@ operationDefinition =
5252
<?> "operationDefinition error!"
5353

5454
node :: Parser AST.Node
55-
node = AST.Node <$> optempty nameParser
55+
node = AST.Node <$> optional nameParser
5656
<*> optempty variableDefinitions
5757
<*> optempty directives
5858
<*> selectionSet

src/GraphQL/Internal/Validation.hs

+22-22
Original file line numberDiff line numberDiff line change
@@ -123,7 +123,7 @@ getSelectionSet (Mutation _ _ ss) = ss
123123
-- | Type alias for 'Query' and 'Mutation' constructors of 'Operation'.
124124
type OperationType value = VariableDefinitions -> Directives value -> SelectionSetByType value -> Operation value
125125

126-
type Operations value = Map Name (Operation value)
126+
type Operations value = Map (Maybe Name) (Operation value)
127127

128128
-- | Turn a parsed document into a known valid one.
129129
--
@@ -132,9 +132,9 @@ type Operations value = Map Name (Operation value)
132132
validate :: Schema -> AST.QueryDocument -> Either (NonEmpty ValidationError) (QueryDocument VariableValue)
133133
validate schema (AST.QueryDocument defns) = runValidator $ do
134134
let (operations, fragments) = splitBy splitDefns defns
135-
let (anonymous, named) = splitBy splitOps operations
135+
let (anonymous, maybeNamed) = splitBy splitOps operations
136136
(frags, visitedFrags) <- resolveFragmentDefinitions =<< validateFragmentDefinitions schema fragments
137-
case (anonymous, named) of
137+
case (anonymous, maybeNamed) of
138138
([], ops) -> do
139139
(validOps, usedFrags) <- runStateT (validateOperations schema frags ops) mempty
140140
assertAllFragmentsUsed frags (visitedFrags <> usedFrags)
@@ -146,7 +146,7 @@ validate schema (AST.QueryDocument defns) = runValidator $ do
146146
validValuesSS <- validateValues ss
147147
resolvedValuesSS <- resolveVariables emptyVariableDefinitions validValuesSS
148148
pure (LoneAnonymousOperation (Query emptyVariableDefinitions emptyDirectives resolvedValuesSS))
149-
_ -> throwE (MixedAnonymousOperations (length anonymous) (map fst named))
149+
_ -> throwE (MixedAnonymousOperations (length anonymous) (map fst maybeNamed))
150150

151151
where
152152
splitBy :: (a -> Either b c) -> [a] -> ([b], [c])
@@ -156,17 +156,17 @@ validate schema (AST.QueryDocument defns) = runValidator $ do
156156
splitDefns (AST.DefinitionFragment frag) = Right frag
157157

158158
splitOps (AST.AnonymousQuery ss) = Left ss
159-
splitOps (AST.Query node@(AST.Node name _ _ _)) = Right (name, (Query, node))
160-
splitOps (AST.Mutation node@(AST.Node name _ _ _)) = Right (name, (Mutation, node))
159+
splitOps (AST.Query node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Query, node))
160+
splitOps (AST.Mutation node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Mutation, node))
161161

162-
assertAllFragmentsUsed :: Fragments value -> Set Name -> Validation ()
162+
assertAllFragmentsUsed :: Fragments value -> Set (Maybe Name) -> Validation ()
163163
assertAllFragmentsUsed fragments used =
164-
let unused = Map.keysSet fragments `Set.difference` used
164+
let unused = ( Set.map pure (Map.keysSet fragments)) `Set.difference` used
165165
in unless (Set.null unused) (throwE (UnusedFragments unused))
166166

167167
-- * Operations
168168

169-
validateOperations :: Schema -> Fragments AST.Value -> [(Name, (OperationType AST.Value, AST.Node))] -> StateT (Set Name) Validation (Operations AST.Value)
169+
validateOperations :: Schema -> Fragments AST.Value -> [(Maybe Name, (OperationType AST.Value, AST.Node))] -> StateT (Set (Maybe Name)) Validation (Operations AST.Value)
170170
validateOperations schema fragments ops = do
171171
deduped <- lift (mapErrors DuplicateOperation (makeMap ops))
172172
traverse validateNode deduped
@@ -219,7 +219,7 @@ validateOperation (Mutation vars directives selectionSet) = do
219219
-- We do this /before/ validating the values (since that's much easier once
220220
-- everything is in a nice structure and away from the AST), which means we
221221
-- can't yet evaluate directives.
222-
validateSelectionSet :: Schema -> Fragments AST.Value -> [AST.Selection] -> StateT (Set Name) Validation (SelectionSetByType AST.Value)
222+
validateSelectionSet :: Schema -> Fragments AST.Value -> [AST.Selection] -> StateT (Set (Maybe Name)) Validation (SelectionSetByType AST.Value)
223223
validateSelectionSet schema fragments selections = do
224224
unresolved <- lift $ traverse (validateSelection schema) selections
225225
resolved <- traverse (resolveSelection fragments) unresolved
@@ -508,14 +508,14 @@ validateSelection schema selection =
508508
-- We're doing a standard depth-first traversal of fragment references, where
509509
-- references are by name, so the set of names can be thought of as a record
510510
-- of visited references.
511-
resolveSelection :: Fragments a -> Selection' UnresolvedFragmentSpread a -> StateT (Set Name) Validation (Selection' FragmentSpread a)
511+
resolveSelection :: Fragments a -> Selection' UnresolvedFragmentSpread a -> StateT (Set (Maybe Name)) Validation (Selection' FragmentSpread a)
512512
resolveSelection fragments = traverseFragmentSpreads resolveFragmentSpread
513513
where
514514
resolveFragmentSpread (UnresolvedFragmentSpread name directive) = do
515515
case Map.lookup name fragments of
516516
Nothing -> lift (throwE (NoSuchFragment name))
517517
Just fragment -> do
518-
modify (Set.insert name)
518+
modify (Set.insert (pure name))
519519
pure (FragmentSpread name directive fragment)
520520

521521
-- * Fragment definitions
@@ -577,7 +577,7 @@ validateTypeCondition schema (NamedType typeCond) =
577577
--
578578
-- <https://facebook.github.io/graphql/#sec-Fragment-spread-target-defined>
579579
-- <https://facebook.github.io/graphql/#sec-Fragment-spreads-must-not-form-cycles>
580-
resolveFragmentDefinitions :: Map Name (FragmentDefinition UnresolvedFragmentSpread value) -> Validation (Fragments value, Set Name)
580+
resolveFragmentDefinitions :: Map Name (FragmentDefinition UnresolvedFragmentSpread value) -> Validation (Fragments value, Set (Maybe Name))
581581
resolveFragmentDefinitions allFragments =
582582
splitResult <$> traverse resolveFragment allFragments
583583
where
@@ -595,12 +595,12 @@ resolveFragmentDefinitions allFragments =
595595
FragmentDefinition name cond directives <$> traverse (traverseFragmentSpreads resolveSpread) ss
596596

597597
resolveSpread (UnresolvedFragmentSpread name directives) = do
598-
visited <- Set.member name <$> get
598+
visited <- Set.member (pure name) <$> get
599599
when visited (lift (throwE (CircularFragmentSpread name)))
600600
case Map.lookup name allFragments of
601601
Nothing -> lift (throwE (NoSuchFragment name))
602602
Just definition -> do
603-
modify (Set.insert name)
603+
modify (Set.insert (pure name))
604604
FragmentSpread name directives <$> resolveFragment' definition
605605

606606
-- * Arguments
@@ -727,12 +727,12 @@ data ValidationError
727727
-- with the given name.
728728
--
729729
-- <https://facebook.github.io/graphql/#sec-Operation-Name-Uniqueness>
730-
= DuplicateOperation Name
730+
= DuplicateOperation (Maybe Name)
731731
-- | 'MixedAnonymousOperations' means there was more than one operation
732732
-- defined in a document with an anonymous operation.
733733
--
734734
-- <https://facebook.github.io/graphql/#sec-Lone-Anonymous-Operation>
735-
| MixedAnonymousOperations Int [Name]
735+
| MixedAnonymousOperations Int [Maybe Name]
736736
-- | 'DuplicateArgument' means that multiple copies of the same argument was
737737
-- given to the same field, directive, etc.
738738
| DuplicateArgument Name
@@ -755,7 +755,7 @@ data ValidationError
755755
| CircularFragmentSpread Name
756756
-- | 'UnusedFragments' means that fragments were defined that weren't used.
757757
-- <https://facebook.github.io/graphql/#sec-Fragments-Must-Be-Used>
758-
| UnusedFragments (Set Name)
758+
| UnusedFragments (Set (Maybe Name))
759759
-- | Variables were defined without being used.
760760
-- <https://facebook.github.io/graphql/#sec-All-Variables-Used>
761761
| UnusedVariables (Set Variable)
@@ -777,10 +777,10 @@ data ValidationError
777777
deriving (Eq, Show)
778778

779779
instance GraphQLError ValidationError where
780-
formatError (DuplicateOperation name) = "More than one operation named '" <> show name <> "'"
781-
formatError (MixedAnonymousOperations n names)
782-
| n > 1 && null names = "Multiple anonymous operations defined. Found " <> show n
783-
| otherwise = "Document contains both anonymous operations (" <> show n <> ") and named operations (" <> show names <> ")"
780+
formatError (DuplicateOperation maybeName) = "More than one operation named '" <> show maybeName <> "'"
781+
formatError (MixedAnonymousOperations n maybeNames)
782+
| n > 1 && null maybeNames = "Multiple anonymous operations defined. Found " <> show n
783+
| otherwise = "Document contains both anonymous operations (" <> show n <> ") and named operations (" <> show maybeNames <> ")"
784784
formatError (DuplicateArgument name) = "More than one argument named '" <> show name <> "'"
785785
formatError (DuplicateFragmentDefinition name) = "More than one fragment named '" <> show name <> "'"
786786
formatError (NoSuchFragment name) = "No fragment named '" <> show name <> "'"

tests/ASTTests.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -121,7 +121,7 @@ tests = testSpec "AST" $ do
121121
])
122122
, AST.DefinitionOperation
123123
(AST.Query
124-
(AST.Node "getName" [] []
124+
(AST.Node (pure "getName") [] []
125125
[ AST.SelectionField
126126
(AST.Field Nothing dog [] []
127127
[ AST.SelectionField
@@ -145,7 +145,7 @@ tests = testSpec "AST" $ do
145145
let expected = AST.QueryDocument
146146
[ AST.DefinitionOperation
147147
(AST.Query
148-
(AST.Node "houseTrainedQuery"
148+
(AST.Node (pure "houseTrainedQuery")
149149
[ AST.VariableDefinition
150150
(AST.Variable "atOtherHomes")
151151
(AST.TypeNamed (AST.NamedType "Boolean"))

tests/ValidationTests.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -19,8 +19,8 @@ import GraphQL.Internal.Validation
1919
, getErrors
2020
)
2121

22-
me :: Name
23-
me = "me"
22+
me :: Maybe Name
23+
me = pure "me"
2424

2525
someName :: Name
2626
someName = "name"

0 commit comments

Comments
 (0)