Merge pull request #134 from sunwukonga/todo/Node_implements_HasName

Make Node instance of HasName. Implement getName.

Author: jml

src/GraphQL/Internal/Name.hs

@@ -5,10 +5,11 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module GraphQL.Internal.Name
-  ( Name(unName)
+  ( Name(unName, Name)
   , NameError(..)
   , makeName
   , nameFromSymbol
+  , nameParser
   -- * Named things
   , HasName(..)
   -- * Unsafe functions
@@ -17,13 +18,57 @@ module GraphQL.Internal.Name
 
 import Protolude
 
+import qualified Data.Aeson as Aeson
 import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
-import GraphQL.Internal.Syntax.AST
-  ( Name(..)
-  , NameError(..)
-  , unsafeMakeName
-  , makeName
-  )
+import Data.Char (isDigit)
+import Data.Text as T (Text)
+import qualified Data.Attoparsec.Text as A
+import Test.QuickCheck (Arbitrary(..), elements, listOf)
+import Data.String (IsString(..))
+
+import GraphQL.Internal.Syntax.Tokens (tok)
+
+-- * Name
+
+-- | A name in GraphQL.
+--
+-- https://facebook.github.io/graphql/#sec-Names
+newtype Name = Name { unName :: T.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 NameError.
+--
+-- >>> 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)
+
+-- | Parser for 'Name'.
+nameParser :: A.Parser Name
+nameParser = Name <$> tok ((<>) <$> A.takeWhile1 isA_z
+                                <*> A.takeWhile ((||) <$> isDigit <*> isA_z))
+  where
+    -- `isAlpha` handles many more Unicode Chars
+    isA_z = A.inClass $ '_' : ['A'..'Z'] <> ['a'..'z']
+
+-- | An invalid name.
+newtype NameError = NameError Text deriving (Eq, Show)
 
 -- | Convert a type-level 'Symbol' into a GraphQL 'Name'.
 nameFromSymbol :: forall (n :: Symbol). KnownSymbol n => Either NameError Name
@@ -41,3 +86,18 @@ nameFromSymbol = makeName (toS (symbolVal @n Proxy))
 class HasName a where
   -- | Get the name of the object.
   getName :: a -> Name
+
+instance IsString Name where
+  fromString = unsafeMakeName . toS
+
+instance Aeson.ToJSON Name where
+  toJSON = Aeson.toJSON . unName
+
+instance Arbitrary Name where
+  arbitrary = do
+    initial <- elements alpha
+    rest <- listOf (elements (alpha <> numeric))
+    pure (Name (toS (initial:rest)))
+    where
+      alpha = ['A'..'Z'] <> ['a'..'z'] <> ['_']
+      numeric = ['0'..'9']

src/GraphQL/Internal/Syntax/AST.hs

@@ -4,17 +4,11 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module GraphQL.Internal.Syntax.AST
-  ( Name(unName)
-  , nameParser
-  , NameError(..)
-  , unsafeMakeName
-  , makeName
-  , QueryDocument(..)
+  ( QueryDocument(..)
   , SchemaDocument(..)
   , Definition(..)
   , OperationDefinition(..)
   , Node(..)
-  , getNodeName
   , VariableDefinition(..)
   , Variable(..)
   , SelectionSet
@@ -54,72 +48,11 @@ module GraphQL.Internal.Syntax.AST
 
 import Protolude
 
-import qualified Data.Aeson as Aeson
-import qualified Data.Attoparsec.Text as A
-import Data.Char (isDigit)
-import Data.String (IsString(..))
+--import Data.String (IsString(..))
 import Test.QuickCheck (Arbitrary(..), elements, listOf, oneof)
 
 import GraphQL.Internal.Arbitrary (arbitraryText)
-import GraphQL.Internal.Syntax.Tokens (tok)
-
--- * Name
-
--- | A name in GraphQL.
---
--- 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
-
-instance Arbitrary Name where
-  arbitrary = do
-    initial <- elements alpha
-    rest <- listOf (elements (alpha <> numeric))
-    pure (Name (toS (initial:rest)))
-    where
-      alpha = ['A'..'Z'] <> ['a'..'z'] <> ['_']
-      numeric = ['0'..'9']
-
--- | Parser for 'Name'.
-nameParser :: A.Parser Name
-nameParser = Name <$> tok ((<>) <$> A.takeWhile1 isA_z
-                                <*> A.takeWhile ((||) <$> isDigit <*> isA_z))
-  where
-    -- `isAlpha` handles many more Unicode Chars
-    isA_z = A.inClass $ '_' : ['A'..'Z'] <> ['a'..'z']
+import GraphQL.Internal.Name (HasName(getName), Name(unName, Name), unsafeMakeName)
 
 -- * Documents
 
@@ -146,9 +79,8 @@ data OperationDefinition
 data Node = Node Name [VariableDefinition] [Directive] SelectionSet
             deriving (Eq,Show)
 
--- TODO: Just make Node implement HasName.
-getNodeName :: Node -> Name
-getNodeName (Node name _ _ _) = name
+instance HasName Node where
+  getName (Node name _ _ _) = name
 
 data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
                           deriving (Eq,Show)

src/GraphQL/Internal/Syntax/Encoder.hs

@@ -10,6 +10,7 @@ import qualified Data.Aeson as Aeson
 import Data.Text (Text, cons, intercalate, pack, snoc)
 
 import qualified GraphQL.Internal.Syntax.AST as AST
+import GraphQL.Internal.Name (unName)
 
 -- * Document
 
@@ -30,7 +31,7 @@ operationDefinition (AST.AnonymousQuery ss) = selectionSet ss
 
 node :: AST.Node -> Text
 node (AST.Node name vds ds ss) =
-     AST.unName name
+     unName name
   <> optempty variableDefinitions vds
   <> optempty directives ds
   <> selectionSet ss
@@ -46,7 +47,7 @@ defaultValue :: AST.DefaultValue -> Text
 defaultValue val = "=" <> value val
 
 variable :: AST.Variable -> Text
-variable (AST.Variable name) = "$" <> AST.unName name
+variable (AST.Variable name) = "$" <> unName name
 
 selectionSet :: AST.SelectionSet -> Text
 selectionSet = bracesCommas selection
@@ -58,8 +59,8 @@ selection (AST.SelectionFragmentSpread x) = fragmentSpread x
 
 field :: AST.Field -> Text
 field (AST.Field alias name args ds ss) =
-       optempty (`snoc` ':') (maybe mempty AST.unName alias)
-    <> AST.unName name
+       optempty (`snoc` ':') (maybe mempty unName alias)
+    <> unName name
     <> optempty arguments args
     <> optempty directives ds
     <> optempty selectionSet ss
@@ -68,17 +69,17 @@ arguments :: [AST.Argument] -> Text
 arguments = parensCommas argument
 
 argument :: AST.Argument -> Text
-argument (AST.Argument name v) = AST.unName name <> ":" <> value v
+argument (AST.Argument name v) = unName name <> ":" <> value v
 
 -- * Fragments
 
 fragmentSpread :: AST.FragmentSpread -> Text
 fragmentSpread (AST.FragmentSpread name ds) =
-  "..." <> AST.unName name <> optempty directives ds
+  "..." <> unName name <> optempty directives ds
 
 inlineFragment :: AST.InlineFragment -> Text
 inlineFragment (AST.InlineFragment (Just (AST.NamedType tc)) ds ss) =
-  "... on " <> AST.unName tc
+  "... on " <> unName tc
             <> optempty directives ds
             <> optempty selectionSet ss
 inlineFragment (AST.InlineFragment Nothing ds ss) =
@@ -87,7 +88,7 @@ inlineFragment (AST.InlineFragment Nothing ds ss) =
 
 fragmentDefinition :: AST.FragmentDefinition -> Text
 fragmentDefinition (AST.FragmentDefinition name (AST.NamedType tc) ds ss) =
-  "fragment " <> AST.unName name <> " on " <> AST.unName tc
+  "fragment " <> unName name <> " on " <> unName tc
               <> optempty directives ds
               <> selectionSet ss
 
@@ -101,7 +102,7 @@ value (AST.ValueInt      x) = pack $ show x
 value (AST.ValueFloat    x) = pack $ show x
 value (AST.ValueBoolean  x) = booleanValue x
 value (AST.ValueString   x) = stringValue x
-value (AST.ValueEnum     x) = AST.unName x
+value (AST.ValueEnum     x) = unName x
 value (AST.ValueList     x) = listValue x
 value (AST.ValueObject   x) = objectValue x
 value AST.ValueNull = "null"
@@ -121,31 +122,31 @@ objectValue :: AST.ObjectValue -> Text
 objectValue (AST.ObjectValue ofs) = bracesCommas objectField ofs
 
 objectField :: AST.ObjectField -> Text
-objectField (AST.ObjectField name v) = AST.unName name <> ":" <> value v
+objectField (AST.ObjectField name v) = unName name <> ":" <> value v
 
 -- * Directives
 
 directives :: [AST.Directive] -> Text
 directives = spaces directive
 
 directive :: AST.Directive -> Text
-directive (AST.Directive name args) = "@" <> AST.unName name <> optempty arguments args
+directive (AST.Directive name args) = "@" <> unName name <> optempty arguments args
 
 -- * Type Reference
 
 type_ :: AST.Type -> Text
-type_ (AST.TypeNamed (AST.NamedType x)) = AST.unName x
+type_ (AST.TypeNamed (AST.NamedType x)) = unName x
 type_ (AST.TypeList x) = listType x
 type_ (AST.TypeNonNull x) = nonNullType x
 
 namedType :: AST.NamedType -> Text
-namedType (AST.NamedType name) = AST.unName name
+namedType (AST.NamedType name) = unName name
 
 listType :: AST.ListType -> Text
 listType (AST.ListType ty) = brackets (type_ ty)
 
 nonNullType :: AST.NonNullType -> Text
-nonNullType (AST.NonNullTypeNamed (AST.NamedType x)) = AST.unName x <> "!"
+nonNullType (AST.NonNullTypeNamed (AST.NamedType x)) = unName x <> "!"
 nonNullType (AST.NonNullTypeList  x) = listType x <> "!"
 
 typeDefinition :: AST.TypeDefinition -> Text
@@ -159,7 +160,7 @@ typeDefinition (AST.TypeDefinitionTypeExtension x) = typeExtensionDefinition x
 
 objectTypeDefinition :: AST.ObjectTypeDefinition -> Text
 objectTypeDefinition (AST.ObjectTypeDefinition name ifaces fds) =
-  "type " <> AST.unName name
+  "type " <> unName name
           <> optempty (spaced . interfaces) ifaces
           <> optempty fieldDefinitions fds
 
@@ -171,7 +172,7 @@ fieldDefinitions = bracesCommas fieldDefinition
 
 fieldDefinition :: AST.FieldDefinition -> Text
 fieldDefinition (AST.FieldDefinition name args ty) =
-  AST.unName name <> optempty argumentsDefinition args
+  unName name <> optempty argumentsDefinition args
                        <> ":"
                        <> type_ ty
 
@@ -180,36 +181,36 @@ argumentsDefinition = parensCommas inputValueDefinition
 
 interfaceTypeDefinition :: AST.InterfaceTypeDefinition -> Text
 interfaceTypeDefinition (AST.InterfaceTypeDefinition name fds) =
-  "interface " <> AST.unName name <> fieldDefinitions fds
+  "interface " <> unName name <> fieldDefinitions fds
 
 unionTypeDefinition :: AST.UnionTypeDefinition -> Text
 unionTypeDefinition (AST.UnionTypeDefinition name ums) =
-  "union " <> AST.unName name <> "=" <> unionMembers ums
+  "union " <> unName name <> "=" <> unionMembers ums
 
 unionMembers :: [AST.NamedType] -> Text
 unionMembers = intercalate "|" . fmap namedType
 
 scalarTypeDefinition :: AST.ScalarTypeDefinition -> Text
-scalarTypeDefinition (AST.ScalarTypeDefinition name) = "scalar " <> AST.unName name
+scalarTypeDefinition (AST.ScalarTypeDefinition name) = "scalar " <> unName name
 
 enumTypeDefinition :: AST.EnumTypeDefinition -> Text
 enumTypeDefinition (AST.EnumTypeDefinition name evds) =
-  "enum " <> AST.unName name
+  "enum " <> unName name
           <> bracesCommas enumValueDefinition evds
 
 enumValueDefinition :: AST.EnumValueDefinition -> Text
-enumValueDefinition (AST.EnumValueDefinition name) = AST.unName name
+enumValueDefinition (AST.EnumValueDefinition name) = unName name
 
 inputObjectTypeDefinition :: AST.InputObjectTypeDefinition -> Text
 inputObjectTypeDefinition (AST.InputObjectTypeDefinition name ivds) =
-  "input " <> AST.unName name <> inputValueDefinitions ivds
+  "input " <> unName name <> inputValueDefinitions ivds
 
 inputValueDefinitions :: [AST.InputValueDefinition] -> Text
 inputValueDefinitions = bracesCommas inputValueDefinition
 
 inputValueDefinition :: AST.InputValueDefinition -> Text
 inputValueDefinition (AST.InputValueDefinition name ty dv) =
-  AST.unName name <> ":" <> type_ ty <> maybe mempty defaultValue dv
+  unName name <> ":" <> type_ ty <> maybe mempty defaultValue dv
 
 typeExtensionDefinition :: AST.TypeExtensionDefinition -> Text
 typeExtensionDefinition (AST.TypeExtensionDefinition otd) =