Adds quickcheck test for JSON parser

package.yaml

@@ -33,7 +33,7 @@ executables:
   ppj:
     main:                Main.hs
     source-dirs:         app
-    ghc-options: []
+    ghc-options: -O2
     dependencies:
     - json-parser
     - pretty-simple
@@ -42,9 +42,7 @@ tests:
   json-parser-test:
     main:                Spec.hs
     source-dirs:         test
-    ghc-options:
-    - -threaded
-    - -rtsopts
-    - -with-rtsopts=-N
+    ghc-options: -O2
     dependencies:
     - json-parser
+    - QuickCheck

src/jsonparser.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
 module JSONParser where
 
 import Control.Applicative (Alternative(..), optional)
@@ -5,6 +6,7 @@ import Control.Monad (replicateM)
 import Data.Char (isDigit, isHexDigit, isSpace, isControl, chr, digitToInt)
 import Data.Functor (($>))
 import Data.List (intercalate)
+import GHC.Generics (Generic)
 
 newtype Parser i o = Parser { runParser :: i -> Maybe (i, o) }
 
@@ -60,7 +62,7 @@ data JValue = JNull
             | JNumber { significand :: Integer, exponent :: Integer}
             | JArray [JValue]
             | JObject [(String, JValue)]
-            deriving (Eq)
+            deriving (Eq, Generic)
 
 instance Show JValue where
   show value = case value of
@@ -68,9 +70,15 @@ instance Show JValue where
     JBool True  -> "true"
     JBool False -> "false"
     JString s   -> "\"" ++ s ++ "\""
-    JNumber s e -> if e == 0 then show s else show s ++ "e" ++ show e
+    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) ++ "}"
+    where
+      toDouble :: Integer -> Integer -> Double
+      toDouble s e = fromInteger s * 10 ^^ e
 
 jNull :: Parser String JValue
 jNull = string "null" $> JNull

test/Spec.hs

@@ -1,2 +1,43 @@
+module Main where
+
+import Control.Monad (unless)
+import Data.Char (isControl, isAscii, isPrint)
+import System.Exit
+import Test.QuickCheck
+import Test.QuickCheck.Test (isSuccess)
+
+import JSONParser
+
 main :: IO ()
-main = putStrLn "Test suite not yet implemented"
+main = do
+  result <- verboseCheckWithResult (stdArgs { maxSize = 40 }) $ \j -> parseJSON (show j) == Just j
+  unless (isSuccess result) exitFailure
+
+instance Arbitrary JValue where
+  arbitrary = sized go
+    where
+      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))
+                        ]
+
+      scaleComp n = n * 2 `div` 3
+
+      go 0 = oneof scalarGens
+      go n = frequency [(2, oneof scalarGens), (3, oneof (compositeGens n))]
+
+      arbitraryJSONString = listOf arbitraryJSONChar'
+
+      arbitraryJSONChar' =
+        arbitraryUnicodeChar `suchThat` (\c -> isAscii c && isPrint c && not (c == '\"' || c == '\\' || isControl c))
+
+      arbitraryJSONChar = frequency [
+          (99, arbitraryJSONChar')
+        , (1, elements ['"' , '\\' , '\b' , '\f' , '\n' , '\r' , '\t'])
+        ]
+
+  shrink = genericShrink