json 0.4.2 → 0.4.3
raw patch · 4 files changed
+110/−70 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGES +10/−0
- Text/JSON/String.hs +94/−68
- json.cabal +1/−1
- tests/Makefile +5/−1
CHANGES view
@@ -1,3 +1,13 @@+Version 0.4.3: released 2009-01-17; changes from 0.4.2++ * optimize some common cases..string and int literals.+ Reduces parse times by > 2x on larger dict inputs containing+ both kinds of lits.++Version 0.4.2: released 2009-01-17; changes from 0.4.1++ * fixed Cabal build issues with various versions of 'base' and Data.Generic+ * fixed whitespace-handling bug in Parsec-based frontend. Version 0.4.1: released 2009-01-12; changes from 0.3.6
Text/JSON/String.hs view
@@ -13,35 +13,45 @@ -- Basic support for working with JSON values. -- -module Text.JSON.String (- -- * Parsing- --- GetJSON, runGetJSON-- -- ** Reading JSON- , readJSNull, readJSBool, readJSString, readJSRational- , readJSArray, readJSObject+module Text.JSON.String + ( + -- * Parsing+ --+ GetJSON+ , runGetJSON - , readJSValue, readJSTopType+ -- ** Reading JSON+ , readJSNull+ , readJSBool+ , readJSString+ , readJSRational+ , readJSArray+ , readJSObject - -- ** Writing JSON- , showJSNull, showJSBool, showJSArray- , showJSObject, showJSRational, showJSRational'+ , readJSValue+ , readJSTopType - , showJSValue, showJSTopType+ -- ** Writing JSON+ , showJSNull+ , showJSBool+ , showJSArray+ , showJSObject+ , showJSRational+ , showJSRational' - ) where+ , showJSValue+ , showJSTopType+ ) where import Text.JSON.Types (JSValue(..), JSString, toJSString, fromJSString, JSObject, toJSObject, fromJSObject) import Control.Monad (liftM)-import Data.Char (isSpace, isDigit)+import Data.Char (isSpace, isDigit, digitToInt) import Data.Ratio (numerator, denominator, (%)) import Numeric (readHex, readDec, showHex) - -- ----------------------------------------------------------------- -- | Parsing JSON @@ -112,34 +122,37 @@ '"' : cs -> parse [] cs _ -> fail $ "Malformed JSON: expecting string: " ++ context x - where parse rs cs = rs `seq` case cs of- '\\' : c : ds -> esc rs c ds- '"' : ds -> do setInput ds- return . JSString . toJSString . reverse $ rs- c : ds- | (c `elem` (['\x20'..'\x21'] ++ ['\x23'..'\x5B'])) || (c >='\x5D' && c <= '\x10FFFF')- -> parse (c:rs) ds- | otherwise- -> fail $ "Illegal unescaped character in string: " ++ context cs- _ -> fail $ "Unable to parse JSON String: unterminated String: " ++ context cs+ where + parse rs cs = + case cs of+ '\\' : c : ds -> esc rs c ds+ '"' : ds -> do setInput ds+ return (JSString (toJSString (reverse rs)))+ c : ds+ | c >= '\x20' && c <= '\xff' -> parse (c:rs) ds+ | c < '\x20' -> fail $ "Illegal unescaped character in string: " ++ context cs+ | i <= 0x10fffff -> parse (c:rs) ds+ | otherwise -> fail $ "Illegal unescaped character in string: " ++ context cs+ where+ i = (fromIntegral (fromEnum c) :: Integer) - esc rs c cs = case c of- '\\' -> parse ('\\' : rs) cs- '"' -> parse ('"' : rs) cs- 'n' -> parse ('\n' : rs) cs- 'r' -> parse ('\r' : rs) cs- 't' -> parse ('\t' : rs) cs- 'f' -> parse ('\f' : rs) cs- 'b' -> parse ('\b' : rs) cs- '/' -> parse ('/' : rs) cs- 'u' -> case cs of- d1 : d2 : d3 : d4 : cs' ->- case readHex [d1,d2,d3,d4] of- [(n,"")] -> parse (toEnum n : rs) cs'+ esc rs c cs = case c of+ '\\' -> parse ('\\' : rs) cs+ '"' -> parse ('"' : rs) cs+ 'n' -> parse ('\n' : rs) cs+ 'r' -> parse ('\r' : rs) cs+ 't' -> parse ('\t' : rs) cs+ 'f' -> parse ('\f' : rs) cs+ 'b' -> parse ('\b' : rs) cs+ '/' -> parse ('/' : rs) cs+ 'u' -> case cs of+ d1 : d2 : d3 : d4 : cs' ->+ case readHex [d1,d2,d3,d4] of+ [(n,"")] -> parse (toEnum n : rs) cs' - x -> fail $ "Unable to parse JSON String: invalid hex: " ++ context (show x)- _ -> fail $ "Unable to parse JSON String: invalid hex: " ++ context cs- _ -> fail $ "Unable to parse JSON String: invalid escape char: " ++ show c+ x -> fail $ "Unable to parse JSON String: invalid hex: " ++ context (show x)+ _ -> fail $ "Unable to parse JSON String: invalid hex: " ++ context cs+ _ -> fail $ "Unable to parse JSON String: invalid escape char: " ++ show c -- | Read an Integer or Double in JSON format, returning a Rational@@ -150,35 +163,48 @@ '-' : ds -> negate <$> pos ds _ -> pos cs - where pos ('0':cs) = frac 0 cs- pos cs = case span isDigit cs of- ([],_) -> fail $ "Unable to parse JSON Rational: " ++ context cs- (xs,ys) -> frac (fromInteger (read xs)) ys+ where + pos [] = fail $ "Unable to parse JSON Rational: " ++ context []+ pos (c:cs) =+ case c of+ '0' -> frac 0 cs+ _ + | not (isDigit c) -> fail $ "Unable to parse JSON Rational: " ++ context cs+ | otherwise -> readDigits (digitToIntI c) cs - frac n cs = case cs of- '.' : ds ->- case span isDigit ds of- ([],_) -> setInput cs >> return n- (as,bs) -> let x = read as :: Integer- y = 10 ^ (fromIntegral (length as) :: Integer)- in exponent' (n + (x % y)) bs- _ -> exponent' n cs+ readDigits acc [] = frac (fromInteger acc) []+ readDigits acc (x:xs)+ | isDigit x = let acc' = 10*acc + digitToIntI x in + acc' `seq` readDigits acc' xs+ | otherwise = frac (fromInteger acc) (x:xs) - exponent' n (c:cs)- | c == 'e' || c == 'E' = (n*) <$> exp_num cs- exponent' n cs = setInput cs >> return n+ frac n ('.' : ds) = + case span isDigit ds of+ ([],_) -> setInput ds >> return n+ (as,bs) -> let x = read as :: Integer+ y = 10 ^ (fromIntegral (length as) :: Integer)+ in exponent' (n + (x % y)) bs+ frac n cs = exponent' n cs - exp_num :: String -> GetJSON Rational- exp_num ('+':cs) = exp_digs cs- exp_num ('-':cs) = recip <$> exp_digs cs- exp_num cs = exp_digs cs+ exponent' n (c:cs)+ | c == 'e' || c == 'E' = (n*) <$> exp_num cs+ exponent' n cs = setInput cs >> return n - exp_digs :: String -> GetJSON Rational- exp_digs cs = case readDec cs of- [(a,ds)] -> do setInput ds- return (fromIntegral ((10::Integer) ^ (a::Integer)))- _ -> fail $ "Unable to parse JSON exponential: " ++ context cs+ exp_num :: String -> GetJSON Rational+ exp_num ('+':cs) = exp_digs cs+ exp_num ('-':cs) = recip <$> exp_digs cs+ exp_num cs = exp_digs cs + exp_digs :: String -> GetJSON Rational+ exp_digs cs = case readDec cs of+ [(a,ds)] -> do setInput ds+ return (fromIntegral ((10::Integer) ^ (a::Integer)))+ _ -> fail $ "Unable to parse JSON exponential: " ++ context cs++ digitToIntI :: Char -> Integer+ digitToIntI ch = fromIntegral (digitToInt ch)++ -- | Read a list in JSON format readJSArray :: GetJSON JSValue readJSArray = readSequence '[' ']' ',' >>= return . JSArray@@ -222,13 +248,13 @@ where parsePairs rs = rs `seq` do a <- do k <- do x <- readJSString ; case x of- JSString s -> return s+ JSString s -> return (fromJSString s) _ -> fail $ "Malformed JSON field labels: object keys must be quoted strings." ds <- getInput case dropWhile isSpace ds of ':':es -> do setInput (dropWhile isSpace es) v <- readJSValue- return (fromJSString k,v)+ return (k,v) _ -> fail $ "Malformed JSON labelled field: " ++ context ds ds <- getInput
json.cabal view
@@ -1,5 +1,5 @@ name: json-version: 0.4.2+version: 0.4.3 synopsis: Support for serialising Haskell to and from JSON description: JSON (JavaScript Object Notation) is a lightweight data-interchange
tests/Makefile view
@@ -5,12 +5,16 @@ all: $(ODIR) ghc -cpp -O QC.hs --make -o QC -no-recomp -i.. -odir=$(ODIR) -hidir=$(ODIR)- time ./QC+# time ./QC+ ./QC runhaskell -i.. HUnit.hs generic: $(ODIR) ghc -i.. --make -fforce-recomp -odir=$(ODIR) -hidir=$(ODIR) GenericTest.hs -o GenericTest ./GenericTest++perf:+ ghc -i.. --make Perf.hs clean: $(RM) -r $(ODIR)