Fixes show instance to fix the tests.

+ fixes JSON string generator.
master
Abhinav Sarkar 2018-03-02 20:34:02 +05:30
parent 985e733d4a
commit d1556166f7
2 changed files with 46 additions and 20 deletions

View File

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

View File

@ -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))]
scaledListOf = scale (\n -> n * 2 `div` 3) . listOf
arbitraryJSONString = listOf arbitraryJSONChar'
arbitraryJSONString :: Gen String
arbitraryJSONString = listOf arbitraryJSONChar
where
arbitraryJSONChar' =
frequency [(9, arbitraryASCIIChar), (0, choose ('\128', '\65535'))]
`suchThat` (\c -> not (c == '\"' || c == '\\' || isControl c))
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
arbitraryJSONChar = frequency [
(99, arbitraryJSONChar')
, (1, elements ['"' , '\\' , '\b' , '\f' , '\n' , '\r' , '\t'])
]