Fixes show instance to fix the tests.

+ fixes JSON string generator.

src/jsonparser.hs

@@ -3,10 +3,12 @@ module JSONParser where
 
 import Control.Applicative (Alternative(..), optional)
 import Control.Monad (replicateM)
-import Data.Char (isDigit, isHexDigit, isSpace, isControl, chr, digitToInt)
+import Data.Char (isDigit, isHexDigit, isSpace, isControl, isAscii, chr, ord, digitToInt)
 import Data.Functor (($>))
 import Data.List (intercalate)
 import GHC.Generics (Generic)
+import Numeric (showHex)
+import Text.Printf (printf)
 
 newtype Parser i o = Parser { runParser :: i -> Maybe (i, o) }
 
@@ -69,17 +71,36 @@ instance Show JValue where
     JNull       -> "null"
     JBool True  -> "true"
     JBool False -> "false"
-    JString s   -> "\"" ++ s ++ "\""
+    JString s   -> showJSONString s
     JNumber s e -> case e of
       0 -> show s
       _ | e >= (-5) && e < 0 -> printf ("%." ++ show (abs e) ++ "f") (toDouble s e)
       _ -> show s ++ "e" ++ show e
     JArray a    -> "[" ++ intercalate ", " (map show a) ++ "]"
-    JObject o   -> "{" ++ intercalate ", " (map (\(k, v) -> show k ++ ": " ++ show v) o) ++ "}"
+    JObject o   -> "{" ++ intercalate ", " (map (\(k, v) -> showJSONString k ++ ": " ++ show v) o) ++ "}"
     where
       toDouble :: Integer -> Integer -> Double
       toDouble s e = fromInteger s * 10 ^^ e
 
+      showJSONString s = "\"" ++ concatMap showJSONChar s ++ "\""
+
+      showJSONChar :: Char -> String
+      showJSONChar c = case c of
+        '\'' -> "'"
+        '\"' -> "\\\""
+        '\\' -> "\\\\"
+        '/'  -> "\\/"
+        '\b' -> "\\b"
+        '\f' -> "\\f"
+        '\n' -> "\\n"
+        '\r' -> "\\r"
+        '\t' -> "\\t"
+        _ | isAscii c -> [c]
+        _ -> "\\u" ++ showJSONNonASCIIChar c
+
+      showJSONNonASCIIChar c =
+        let a = "0000" ++ showHex (ord c) "" in drop (length a - 4) a
+
 jNull :: Parser String JValue
 jNull = string "null" $> JNull
 

test/Spec.hs

@@ -1,7 +1,7 @@
 module Main where
 
 import Control.Monad (unless)
-import Data.Char (isControl, isAscii, isPrint)
+import Data.Char (isControl)
 import System.Exit
 import Test.QuickCheck
 import Test.QuickCheck.Test (isSuccess)
@@ -10,34 +10,39 @@ import JSONParser
 
 main :: IO ()
 main = do
-  result <- verboseCheckWithResult (stdArgs { maxSize = 40 }) $ \j -> parseJSON (show j) == Just j
+  result <- quickCheckResult $ \j -> parseJSON (show j) == Just j
   unless (isSuccess result) exitFailure
 
 instance Arbitrary JValue where
+  shrink = genericShrink
+
   arbitrary = sized go
     where
+      go 0 = oneof scalarGens
+      go n = frequency [(2, oneof scalarGens), (3, oneof (compositeGens n))]
+
       scalarGens = [ pure JNull
                    , JBool   <$> arbitrary
                    , JString <$> arbitraryJSONString
                    , JNumber <$> arbitrary <*> oneof [choose (-5, 0), arbitrary]
                    ]
-      compositeGens n = [ fmap JArray . scale scaleComp . listOf . go $ n `div` 2
-                        , fmap JObject . scale scaleComp . listOf $ ((,) <$> arbitraryJSONString <*> go (n `div` 2))
+
+      compositeGens n = [ fmap JArray  . scaledListOf . go    $ n `div` 2
+                        , fmap JObject . scaledListOf . objKV $ n `div` 2
                         ]
 
-      scaleComp n = n * 2 `div` 3
+      objKV n = (,) <$> arbitraryJSONString <*> go n
 
-      go 0 = oneof scalarGens
-      go n = frequency [(2, oneof scalarGens), (3, oneof (compositeGens n))]
-
-      arbitraryJSONString = listOf arbitraryJSONChar'
+      scaledListOf = scale (\n -> n * 2 `div` 3) . listOf
 
+arbitraryJSONString :: Gen String
+arbitraryJSONString = listOf arbitraryJSONChar
+  where
     arbitraryJSONChar' =
-        arbitraryUnicodeChar `suchThat` (\c -> isAscii c && isPrint c && not (c == '\"' || c == '\\' || isControl c))
+      frequency [(9, arbitraryASCIIChar), (0, choose ('\128', '\65535'))]
+        `suchThat` (\c -> not (c == '\"' || c == '\\' || isControl c))
 
     arbitraryJSONChar = frequency [
         (99, arbitraryJSONChar')
       , (1, elements ['"' , '\\' , '\b' , '\f' , '\n' , '\r' , '\t'])
       ]
-
-  shrink = genericShrink