Adds quickcheck test for JSON parser
parent
b9a6240c37
commit
985e733d4a
|
@ -33,7 +33,7 @@ executables:
|
||||||
ppj:
|
ppj:
|
||||||
main: Main.hs
|
main: Main.hs
|
||||||
source-dirs: app
|
source-dirs: app
|
||||||
ghc-options: []
|
ghc-options: -O2
|
||||||
dependencies:
|
dependencies:
|
||||||
- json-parser
|
- json-parser
|
||||||
- pretty-simple
|
- pretty-simple
|
||||||
|
@ -42,9 +42,7 @@ tests:
|
||||||
json-parser-test:
|
json-parser-test:
|
||||||
main: Spec.hs
|
main: Spec.hs
|
||||||
source-dirs: test
|
source-dirs: test
|
||||||
ghc-options:
|
ghc-options: -O2
|
||||||
- -threaded
|
|
||||||
- -rtsopts
|
|
||||||
- -with-rtsopts=-N
|
|
||||||
dependencies:
|
dependencies:
|
||||||
- json-parser
|
- json-parser
|
||||||
|
- QuickCheck
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
module JSONParser where
|
module JSONParser where
|
||||||
|
|
||||||
import Control.Applicative (Alternative(..), optional)
|
import Control.Applicative (Alternative(..), optional)
|
||||||
|
@ -5,6 +6,7 @@ import Control.Monad (replicateM)
|
||||||
import Data.Char (isDigit, isHexDigit, isSpace, isControl, chr, digitToInt)
|
import Data.Char (isDigit, isHexDigit, isSpace, isControl, chr, digitToInt)
|
||||||
import Data.Functor (($>))
|
import Data.Functor (($>))
|
||||||
import Data.List (intercalate)
|
import Data.List (intercalate)
|
||||||
|
import GHC.Generics (Generic)
|
||||||
|
|
||||||
newtype Parser i o = Parser { runParser :: i -> Maybe (i, o) }
|
newtype Parser i o = Parser { runParser :: i -> Maybe (i, o) }
|
||||||
|
|
||||||
|
@ -60,7 +62,7 @@ data JValue = JNull
|
||||||
| JNumber { significand :: Integer, exponent :: Integer}
|
| JNumber { significand :: Integer, exponent :: Integer}
|
||||||
| JArray [JValue]
|
| JArray [JValue]
|
||||||
| JObject [(String, JValue)]
|
| JObject [(String, JValue)]
|
||||||
deriving (Eq)
|
deriving (Eq, Generic)
|
||||||
|
|
||||||
instance Show JValue where
|
instance Show JValue where
|
||||||
show value = case value of
|
show value = case value of
|
||||||
|
@ -68,9 +70,15 @@ instance Show JValue where
|
||||||
JBool True -> "true"
|
JBool True -> "true"
|
||||||
JBool False -> "false"
|
JBool False -> "false"
|
||||||
JString s -> "\"" ++ s ++ "\""
|
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) ++ "]"
|
JArray a -> "[" ++ intercalate ", " (map show a) ++ "]"
|
||||||
JObject o -> "{" ++ intercalate ", " (map (\(k, v) -> show k ++ ": " ++ show v) o) ++ "}"
|
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 :: Parser String JValue
|
||||||
jNull = string "null" $> JNull
|
jNull = string "null" $> JNull
|
||||||
|
|
43
test/Spec.hs
43
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 :: 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
|
||||||
|
|
Loading…
Reference in New Issue