Provide custom Show instances for AST values

2 files changed, 65 insertions, 24 deletions

diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index a65a01d..a78b007 100644
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE Safe #-}
@@ -47,11 +48,15 @@ module Language.GraphQL.AST.Document
     , UnionMemberTypes(..)
     , Value(..)
     , VariableDefinition(..)
+    , escape
     ) where
 
+import Data.Char (ord)
 import Data.Foldable (toList)
 import Data.Int (Int32)
+import Data.List (intercalate)
 import Data.List.NonEmpty (NonEmpty)
+import Numeric (showFloat, showHex)
 import Data.Text (Text)
 import qualified Data.Text as Text
 import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)
@@ -79,7 +84,10 @@ instance Ord Location where
 data Node a = Node
     { node :: a
     , location :: Location
-    } deriving (Eq, Show)
+    } deriving Eq
+
+instance Show a => Show (Node a) where
+    show Node{ node } = show node
 
 instance Functor Node where
     fmap f Node{..} = Node (f node) location
@@ -218,6 +226,28 @@ type TypeCondition = Name
 
 -- ** Input Values
 
+escape :: Char -> String
+escape char'
+    | char' == '\\' = "\\\\"
+    | char' == '\"' = "\\\""
+    | char' == '\b' = "\\b"
+    | char' == '\f' = "\\f"
+    | char' == '\n' = "\\n"
+    | char' == '\r' = "\\r"
+    | char' == '\t' = "\\t"
+    | char' < '\x0010' = unicode  "\\u000" char'
+    | char' < '\x0020' = unicode "\\u00" char'
+    | otherwise = [char']
+  where
+    unicode prefix uchar = prefix <> (showHex $ ord uchar) ""
+
+showList' :: Show a => [a] -> String
+showList' list = "[" ++ intercalate ", " (show <$> list) ++ "]"
+
+showObject :: Show a => [ObjectField a] -> String
+showObject fields =
+    "{ " ++ intercalate ", " (show <$> fields) ++ " }"
+
 -- | Input value (literal or variable).
 data Value
     = Variable Name
@@ -229,7 +259,19 @@ data Value
     | Enum Name
     | List [Value]
     | Object [ObjectField Value]
-    deriving (Eq, Show)
+    deriving Eq
+
+instance Show Value where
+    showList = mappend . showList'
+    show (Variable variableName) = '$' : Text.unpack variableName
+    show (Int integer) = show integer
+    show (Float float) = show $ ConstFloat float
+    show (String text) = show $  ConstString text
+    show (Boolean boolean) = show boolean
+    show Null = "null"
+    show (Enum name) = Text.unpack name
+    show (List list) = show list
+    show (Object fields) = showObject fields
 
 -- | Constant input value.
 data ConstValue
@@ -241,7 +283,18 @@ data ConstValue
     | ConstEnum Name
     | ConstList [ConstValue]
     | ConstObject [ObjectField ConstValue]
-    deriving (Eq, Show)
+    deriving Eq
+
+instance Show ConstValue where
+    showList = mappend . showList'
+    show (ConstInt integer) = show integer
+    show (ConstFloat float) = showFloat float mempty
+    show (ConstString text) = "\"" <> Text.foldr (mappend . escape) "\"" text
+    show (ConstBoolean boolean) = show boolean
+    show ConstNull = "null"
+    show (ConstEnum name) = Text.unpack name
+    show (ConstList list) = show list
+    show (ConstObject fields) = showObject fields
 
 -- | Key-value pair.
 --
@@ -250,7 +303,10 @@ data ObjectField a = ObjectField
     { name :: Name
     , value :: Node a
     , location :: Location
-    } deriving (Eq, Show)
+    } deriving Eq
+
+instance Show a => Show (ObjectField a) where
+    show ObjectField{..} = Text.unpack name ++ ": " ++ show value
 
 instance Functor ObjectField where
     fmap f ObjectField{..} = ObjectField name (f <$> value) location
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
index 9ba51b8..f04f385 100644
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@@ -16,7 +16,6 @@ module Language.GraphQL.AST.Encoder
     , value
     ) where
 
-import Data.Char (ord)
 import Data.Foldable (fold)
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Text (Text)
@@ -25,7 +24,7 @@ import qualified Data.Text.Lazy as Lazy (Text)
 import qualified Data.Text.Lazy as Lazy.Text
 import Data.Text.Lazy.Builder (Builder)
 import qualified Data.Text.Lazy.Builder as Builder
-import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
+import Data.Text.Lazy.Builder.Int (decimal)
 import Data.Text.Lazy.Builder.RealFloat (realFloat)
 import qualified Language.GraphQL.AST.Document as Full
 
@@ -234,11 +233,12 @@ quote :: Builder.Builder
 quote = Builder.singleton '\"'
 
 oneLine :: Text -> Builder
-oneLine string = quote <> Text.foldr (mappend . escape) quote string
+oneLine string = quote <> Text.foldr merge quote string
+  where
+    merge = mappend . Builder.fromString . Full.escape
 
 stringValue :: Formatter -> Text -> Lazy.Text
-stringValue Minified string = Builder.toLazyText
-    $ quote <> Text.foldr (mappend . escape) quote string
+stringValue Minified string = Builder.toLazyText $ oneLine string
 stringValue (Pretty indentation) string =
   if hasEscaped string
   then stringValue Minified string
@@ -266,21 +266,6 @@ stringValue (Pretty indentation) string =
             = Builder.fromLazyText (indent (indentation + 1))
             <> line' <> newline <> acc
 
-escape :: Char -> Builder
-escape char'
-    | char' == '\\' = Builder.fromString "\\\\"
-    | char' == '\"' = Builder.fromString "\\\""
-    | char' == '\b' = Builder.fromString "\\b"
-    | char' == '\f' = Builder.fromString "\\f"
-    | char' == '\n' = Builder.fromString "\\n"
-    | char' == '\r' = Builder.fromString "\\r"
-    | char' == '\t' = Builder.fromString "\\t"
-    | char' < '\x0010' = unicode  "\\u000" char'
-    | char' < '\x0020' = unicode "\\u00" char'
-    | otherwise = Builder.singleton char'
-  where
-    unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord)
-
 listValue :: Formatter -> [Full.Value] -> Lazy.Text
 listValue formatter = bracketsCommas formatter $ value formatter