Make Node instance of HasName. Implement getName

Following todo formerly in src/GraphQL/Internal/Syntax/AST.hs:
  TODO: Just make Node implement HasName.
Declared Node as instance of HasName and wrote implementation of
getname for it.

Because of a cyclic dependency between Name and AST, moved the Name
specific code from GraphQL.Internal.Syntax.AST module into the
GraphQL.Internal.Name module.

Updated imports and exposures in the AST and Name modules described
above.

Simple import and qualified name changes to:
  GraphQL/Internal/Syntax/Encoder
  GraphQL/Internal/Syntax/Parser

Author: sunwukonga

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 qualified Data.Attoparsec.Text as A
+import Test.QuickCheck (Arbitrary(..), elements, listOf)
+import Data.String (IsString(..))
+
+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)
+
+-- | 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 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) =