diff --git a/graphql-api.cabal b/graphql-api.cabal --- a/graphql-api.cabal +++ b/graphql-api.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: graphql-api -version: 0.1.1 +version: 0.1.2 synopsis: Sketch of GraphQL stuff description: Please see README.md category: Web diff --git a/src/GraphQL/Internal/Name.hs b/src/GraphQL/Internal/Name.hs --- a/src/GraphQL/Internal/Name.hs +++ b/src/GraphQL/Internal/Name.hs @@ -17,43 +17,17 @@ import Protolude -import qualified Data.Attoparsec.Text as A import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) import GraphQL.Internal.Syntax.AST ( Name(..) - , nameParser + , NameError(..) + , unsafeMakeName + , makeName ) --- | An invalid name. -newtype NameError = NameError Text deriving (Eq, Show) - --- | Create a 'Name'. --- --- Names must match the regex @[_A-Za-z][_0-9A-Za-z]*@. If the given text does --- not match, return Nothing. --- --- >>> makeName "foo" --- Right (Name {unName = "foo"}) --- >>> makeName "9-bar" --- Left (NameError "9-bar") -makeName :: Text -> Either NameError Name -makeName name = first (const (NameError name)) (A.parseOnly nameParser name) - -- | Convert a type-level 'Symbol' into a GraphQL 'Name'. nameFromSymbol :: forall (n :: Symbol). KnownSymbol n => Either NameError Name nameFromSymbol = makeName (toS (symbolVal @n Proxy)) - --- | Create a 'Name', panicking if the given text is invalid. --- --- Prefer 'makeName' to this in all cases. --- --- >>> unsafeMakeName "foo" --- Name {unName = "foo"} -unsafeMakeName :: HasCallStack => Text -> Name -unsafeMakeName name = - case makeName name of - Left e -> panic (show e) - Right n -> n -- | Types that implement this have values with a single canonical name in a -- GraphQL schema. diff --git a/src/GraphQL/Internal/Output.hs b/src/GraphQL/Internal/Output.hs --- a/src/GraphQL/Internal/Output.hs +++ b/src/GraphQL/Internal/Output.hs @@ -21,7 +21,7 @@ , pattern ValueNull , NameError(..) ) -import GraphQL.Internal.Name (unsafeMakeName) +import GraphQL.Internal.Name (Name) import GraphQL.Value.ToValue (ToValue(..)) -- | GraphQL response. @@ -61,9 +61,9 @@ -- | Construct an object from a list of names and values. -- -- Panic if there are duplicate names. -unsafeMakeObject :: HasCallStack => [(Text, Value)] -> Value +unsafeMakeObject :: HasCallStack => [(Name, Value)] -> Value unsafeMakeObject fields = - case objectFromList (map (first unsafeMakeName) fields) of + case objectFromList fields of Nothing -> panic $ "Object has duplicate keys: " <> show fields Just object -> ValueObject object diff --git a/src/GraphQL/Internal/Schema.hs b/src/GraphQL/Internal/Schema.hs --- a/src/GraphQL/Internal/Schema.hs +++ b/src/GraphQL/Internal/Schema.hs @@ -44,7 +44,7 @@ import qualified Data.Map as Map import GraphQL.Value (Value) -import GraphQL.Internal.Name (HasName(..), Name, unsafeMakeName) +import GraphQL.Internal.Name (HasName(..), Name) -- | An entire GraphQL schema. -- @@ -215,13 +215,11 @@ | GID deriving (Eq, Ord, Show) instance HasName Builtin where - getName = unsafeMakeName . getBuiltinName - where - getBuiltinName GInt = "Int" - getBuiltinName GBool = "Boolean" - getBuiltinName GString = "String" - getBuiltinName GFloat = "Float" - getBuiltinName GID = "ID" + getName GInt = "Int" + getName GBool = "Boolean" + getName GString = "String" + getName GFloat = "Float" + getName GID = "ID" data EnumTypeDefinition = EnumTypeDefinition Name [EnumValueDefinition] deriving (Eq, Ord, Show) diff --git a/src/GraphQL/Internal/Syntax/AST.hs b/src/GraphQL/Internal/Syntax/AST.hs --- a/src/GraphQL/Internal/Syntax/AST.hs +++ b/src/GraphQL/Internal/Syntax/AST.hs @@ -6,6 +6,9 @@ module GraphQL.Internal.Syntax.AST ( Name(unName) , nameParser + , NameError(..) + , unsafeMakeName + , makeName , QueryDocument(..) , SchemaDocument(..) , Definition(..) @@ -54,6 +57,7 @@ import qualified Data.Aeson as Aeson import qualified Data.Attoparsec.Text as A import Data.Char (isDigit) +import Data.String (IsString(..)) import Test.QuickCheck (Arbitrary(..), elements, listOf, oneof) import GraphQL.Internal.Arbitrary (arbitraryText) @@ -65,6 +69,37 @@ -- -- https://facebook.github.io/graphql/#sec-Names newtype Name = Name { unName :: Text } deriving (Eq, Ord, Show) + +-- | Create a 'Name', panicking if the given text is invalid. +-- +-- Prefer 'makeName' to this in all cases. +-- +-- >>> unsafeMakeName "foo" +-- Name {unName = "foo"} +unsafeMakeName :: HasCallStack => Text -> Name +unsafeMakeName name = + case makeName name of + Left e -> panic (show e) + Right n -> n + +-- | Create a 'Name'. +-- +-- Names must match the regex @[_A-Za-z][_0-9A-Za-z]*@. If the given text does +-- not match, return Nothing. +-- +-- >>> makeName "foo" +-- Right (Name {unName = "foo"}) +-- >>> makeName "9-bar" +-- Left (NameError "9-bar") +makeName :: Text -> Either NameError Name +makeName name = first (const (NameError name)) (A.parseOnly nameParser name) + +-- | An invalid name. +newtype NameError = NameError Text deriving (Eq, Show) + + +instance IsString Name where + fromString = unsafeMakeName . toS instance Aeson.ToJSON Name where toJSON = Aeson.toJSON . unName diff --git a/tests/ASTTests.hs b/tests/ASTTests.hs --- a/tests/ASTTests.hs +++ b/tests/ASTTests.hs @@ -13,7 +13,7 @@ import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) import GraphQL.Value (String(..)) -import GraphQL.Internal.Name (Name, unsafeMakeName) +import GraphQL.Internal.Name (Name) import qualified GraphQL.Internal.Syntax.AST as AST import qualified GraphQL.Internal.Syntax.Parser as Parser import qualified GraphQL.Internal.Syntax.Encoder as Encoder @@ -22,10 +22,10 @@ kitchenSink = "query queryName($foo:ComplexType,$site:Site=MOBILE){whoever123is:node(id:[123,456]){id,... on User@defer{field2{id,alias:field1(first:10,after:$foo)@include(if:$foo){id,...frag}}}}}mutation likeStory{like(story:123)@defer{story{id}}}fragment frag on Friend{foo(size:$size,bar:$b,obj:{key:\"value\"})}\n" dog :: Name -dog = unsafeMakeName "dog" +dog = "dog" someName :: Name -someName = unsafeMakeName "name" +someName = "name" tests :: IO TestTree tests = testSpec "AST" $ do @@ -62,9 +62,9 @@ it "parses ununusual objects" $ do let input = AST.ValueObject (AST.ObjectValue - [ AST.ObjectField (unsafeMakeName "s") + [ AST.ObjectField "s" (AST.ValueString (AST.StringValue "\224\225v^6{FPDk\DC3\a")), - AST.ObjectField (unsafeMakeName "Hsr") (AST.ValueInt 0) + AST.ObjectField "Hsr" (AST.ValueInt 0) ]) let output = Encoder.value input parseOnly Parser.value output `shouldBe` Right input @@ -121,11 +121,11 @@ ]) , AST.DefinitionOperation (AST.Query - (AST.Node (unsafeMakeName "getName") [] [] + (AST.Node "getName" [] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField - (AST.Field Nothing (unsafeMakeName "owner") [] [] + (AST.Field Nothing "owner" [] [] [ AST.SelectionField (AST.Field Nothing someName [] [] []) ]) ]) @@ -145,18 +145,18 @@ let expected = AST.QueryDocument [ AST.DefinitionOperation (AST.Query - (AST.Node (unsafeMakeName "houseTrainedQuery") + (AST.Node "houseTrainedQuery" [ AST.VariableDefinition - (AST.Variable (unsafeMakeName "atOtherHomes")) - (AST.TypeNamed (AST.NamedType (unsafeMakeName "Boolean"))) + (AST.Variable "atOtherHomes") + (AST.TypeNamed (AST.NamedType "Boolean")) (Just (AST.ValueBoolean True)) ] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField - (AST.Field Nothing (unsafeMakeName "isHousetrained") - [ AST.Argument (unsafeMakeName "atOtherHomes") - (AST.ValueVariable (AST.Variable (unsafeMakeName "atOtherHomes"))) + (AST.Field Nothing "isHousetrained" + [ AST.Argument "atOtherHomes" + (AST.ValueVariable (AST.Variable "atOtherHomes")) ] [] []) ]) ])) diff --git a/tests/Doctests.hs b/tests/Doctests.hs --- a/tests/Doctests.hs +++ b/tests/Doctests.hs @@ -17,5 +17,5 @@ ] -- library code and examples files = [ "src/" - , "examples/" + , "tests/Examples/" ] diff --git a/tests/ResolverTests.hs b/tests/ResolverTests.hs --- a/tests/ResolverTests.hs +++ b/tests/ResolverTests.hs @@ -24,7 +24,6 @@ , ResolverError(..) , (:<>)(..) ) -import GraphQL.Internal.Name (unsafeMakeName) import GraphQL.Internal.Output (singleError) -- Test a custom error monad @@ -46,7 +45,7 @@ encode object `shouldBe` "{\"t\":12}" it "complains about missing field" $ do Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ not_a_field }") - errs `shouldBe` singleError (FieldNotFoundError (unsafeMakeName "not_a_field")) + errs `shouldBe` singleError (FieldNotFoundError "not_a_field") it "complains about missing argument" $ do Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t }") - errs `shouldBe` singleError (ValueMissing (unsafeMakeName "x")) + errs `shouldBe` singleError (ValueMissing "x") diff --git a/tests/SchemaTests.hs b/tests/SchemaTests.hs --- a/tests/SchemaTests.hs +++ b/tests/SchemaTests.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeOperators #-} module SchemaTests (tests) where @@ -18,7 +17,6 @@ , getFieldDefinition , getInterfaceDefinition ) -import GraphQL.Internal.Name (unsafeMakeName) import GraphQL.Internal.Schema ( EnumTypeDefinition(..) , EnumValueDefinition(..) @@ -41,33 +39,33 @@ tests = testSpec "Type" $ do describe "Field" $ it "encodes correctly" $ do - getFieldDefinition @(Field "hello" Int) `shouldBe` Right (FieldDefinition (unsafeMakeName "hello") [] (TypeNonNull (NonNullTypeNamed (BuiltinType GInt)))) + getFieldDefinition @(Field "hello" Int) `shouldBe` Right (FieldDefinition "hello" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GInt)))) describe "Interface" $ it "encodes correctly" $ do getInterfaceDefinition @Sentient `shouldBe` Right (InterfaceTypeDefinition - (unsafeMakeName "Sentient") - (NonEmptyList [FieldDefinition (unsafeMakeName "name") [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))])) + "Sentient" + (NonEmptyList [FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))])) describe "full example" $ it "encodes correctly" $ do getDefinition @Human `shouldBe` - Right (ObjectTypeDefinition (unsafeMakeName "Human") - [ InterfaceTypeDefinition (unsafeMakeName "Sentient") ( - NonEmptyList [FieldDefinition (unsafeMakeName "name") [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))]) + Right (ObjectTypeDefinition "Human" + [ InterfaceTypeDefinition "Sentient" ( + NonEmptyList [FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))]) ] - (NonEmptyList [FieldDefinition (unsafeMakeName "name") [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))])) + (NonEmptyList [FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))])) describe "output Enum" $ it "encodes correctly" $ do getAnnotatedType @(Enum "DogCommand" DogCommand) `shouldBe` - Right (TypeNonNull (NonNullTypeNamed (DefinedType (TypeDefinitionEnum (EnumTypeDefinition (unsafeMakeName "DogCommand") - [ EnumValueDefinition (unsafeMakeName "Sit") - , EnumValueDefinition (unsafeMakeName "Down") - , EnumValueDefinition (unsafeMakeName "Heel") + Right (TypeNonNull (NonNullTypeNamed (DefinedType (TypeDefinitionEnum (EnumTypeDefinition "DogCommand" + [ EnumValueDefinition "Sit" + , EnumValueDefinition "Down" + , EnumValueDefinition "Heel" ]))))) describe "Union type" $ it "encodes correctly" $ do getAnnotatedType @CatOrDog `shouldBe` - TypeNamed . DefinedType . TypeDefinitionUnion . UnionTypeDefinition (unsafeMakeName "CatOrDog") + TypeNamed . DefinedType . TypeDefinitionUnion . UnionTypeDefinition "CatOrDog" . NonEmptyList <$> sequence [ getDefinition @Cat , getDefinition @Dog ] diff --git a/tests/ValidationTests.hs b/tests/ValidationTests.hs --- a/tests/ValidationTests.hs +++ b/tests/ValidationTests.hs @@ -10,7 +10,7 @@ import Test.Tasty (TestTree) import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) -import GraphQL.Internal.Name (Name, unsafeMakeName) +import GraphQL.Internal.Name (Name) import qualified GraphQL.Internal.Syntax.AST as AST import GraphQL.Internal.Schema (Schema) import GraphQL.Internal.Validation @@ -20,10 +20,10 @@ ) me :: Name -me = unsafeMakeName "me" +me = "me" someName :: Name -someName = unsafeMakeName "name" +someName = "name" -- | Schema used for these tests. Since none of them do type-level stuff, we -- don't need to define it. diff --git a/tests/ValueTests.hs b/tests/ValueTests.hs --- a/tests/ValueTests.hs +++ b/tests/ValueTests.hs @@ -9,7 +9,6 @@ import qualified GraphQL.Internal.Syntax.AST as AST import GraphQL.Internal.Arbitrary (arbitraryText, arbitraryNonEmpty) -import GraphQL.Internal.Name (unsafeMakeName) import GraphQL.Value ( Object , ObjectField'(..) @@ -28,19 +27,19 @@ it "returns empty on empty list" $ do unionObjects [] `shouldBe` (objectFromList [] :: Maybe Object) it "merges objects" $ do - let (Just foo) = objectFromList [ (unsafeMakeName "foo", toValue @Int32 1) - , (unsafeMakeName "bar",toValue @Int32 2)] - let (Just bar) = objectFromList [ (unsafeMakeName "bar", toValue @Text "cow") - , (unsafeMakeName "baz",toValue @Int32 3)] + let (Just foo) = objectFromList [ ("foo", toValue @Int32 1) + , ("bar",toValue @Int32 2)] + let (Just bar) = objectFromList [ ("bar", toValue @Text "cow") + , ("baz",toValue @Int32 3)] let observed = unionObjects [foo, bar] observed `shouldBe` Nothing it "merges objects with unique keys" $ do - let (Just foo) = objectFromList [(unsafeMakeName "foo", toValue @Int32 1)] - let (Just bar) = objectFromList [ (unsafeMakeName "bar", toValue @Text "cow") - , (unsafeMakeName "baz",toValue @Int32 3)] - let (Just expected) = objectFromList [ (unsafeMakeName "foo", toValue @Int32 1) - , (unsafeMakeName "bar", toValue @Text "cow") - , (unsafeMakeName "baz", toValue @Int32 3) + let (Just foo) = objectFromList [("foo", toValue @Int32 1)] + let (Just bar) = objectFromList [ ("bar", toValue @Text "cow") + , ("baz",toValue @Int32 3)] + let (Just expected) = objectFromList [ ("foo", toValue @Int32 1) + , ("bar", toValue @Text "cow") + , ("baz", toValue @Int32 3) ] let (Just observed) = unionObjects [foo, bar] observed `shouldBe` expected @@ -57,8 +56,8 @@ prop "Non-empty lists" $ forAll (arbitraryNonEmpty @Int32) prop_roundtripValue describe "AST" $ do it "Objects converted from AST have unique fields" $ do - let input = AST.ObjectValue [ AST.ObjectField (unsafeMakeName "foo") (AST.ValueString (AST.StringValue "bar")) - , AST.ObjectField (unsafeMakeName "foo") (AST.ValueString (AST.StringValue "qux")) + let input = AST.ObjectValue [ AST.ObjectField "foo" (AST.ValueString (AST.StringValue "bar")) + , AST.ObjectField "foo" (AST.ValueString (AST.StringValue "qux")) ] astToVariableValue (AST.ValueObject input) `shouldBe` Nothing