Adds quickcheck test for JSON parser

master
Abhinav Sarkar 2018-02-23 12:51:03 +05:30
parent b9a6240c37
commit 985e733d4a
3 changed files with 55 additions and 8 deletions

View File

@ -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

View File

@ -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

View File

@ -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