json (empty) → 0.3.3

raw patch · 51 files changed

+2038/−0 lines, 51 filesdep +arraydep +basedep +bytestringsetup-changed

Dependencies added: array, base, bytestring, containers, parsec, pretty

Files

• LICENSE +27/−0
• Setup.hs +4/−0
• Text/JSON.hs +371/−0
• Text/JSON/Parsec.hs +118/−0
• Text/JSON/Pretty.hs +69/−0
• Text/JSON/ReadP.hs +117/−0
• Text/JSON/String.hs +338/−0
• Text/JSON/Types.hs +81/−0
• json.cabal +91/−0
• tests/HUnit.hs +82/−0
• tests/Makefile +13/−0
• tests/Parallel.hs +151/−0
• tests/QC.hs +192/−0
• tests/QuickCheckUtils.hs +272/−0
• tests/Unit.hs +12/−0
• tests/unit/fail1.json +1/−0
• tests/unit/fail10.json +1/−0
• tests/unit/fail11.json +1/−0
• tests/unit/fail12.json +1/−0
• tests/unit/fail13.json +1/−0
• tests/unit/fail14.json +1/−0
• tests/unit/fail15.json +1/−0
• tests/unit/fail16.json +1/−0
• tests/unit/fail17.json +1/−0
• tests/unit/fail18.json +1/−0
• tests/unit/fail19.json +1/−0
• tests/unit/fail2.json +1/−0
• tests/unit/fail20.json +1/−0
• tests/unit/fail21.json +1/−0
• tests/unit/fail22.json +1/−0
• tests/unit/fail23.json +1/−0
• tests/unit/fail24.json +1/−0
• tests/unit/fail25.json +1/−0
• tests/unit/fail26.json +1/−0
• tests/unit/fail27.json +2/−0
• tests/unit/fail28.json +2/−0
• tests/unit/fail29.json +1/−0
• tests/unit/fail3.json +1/−0
• tests/unit/fail30.json +1/−0
• tests/unit/fail31.json +1/−0
• tests/unit/fail32.json +1/−0
• tests/unit/fail33.json +1/−0
• tests/unit/fail4.json +1/−0
• tests/unit/fail5.json +1/−0
• tests/unit/fail6.json +1/−0
• tests/unit/fail7.json +1/−0
• tests/unit/fail8.json +1/−0
• tests/unit/fail9.json +1/−0
• tests/unit/pass1.json +58/−0
• tests/unit/pass2.json +1/−0
• tests/unit/pass3.json +6/−0

@@ -0,0 +1,27 @@+Copyright (c) Galois, Inc. 2007++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.

@@ -0,0 +1,4 @@+module Main where++import Distribution.Simple+main = defaultMain

@@ -0,0 +1,371 @@+--------------------------------------------------------------------+-- |+-- Module    : Text.JSON+-- Copyright : (c) Galois, Inc. 2007+-- License   : BSD3+--+-- Maintainer:  Don Stewart <dons@galois.com>+-- Stability :  provisional+-- Portability: portable+--+--------------------------------------------------------------------+--+-- Serialising Haskell values to and from JSON values.+--++module Text.JSON (+    -- * JSON Types+    JSValue(..)++    -- * Serialization to and from JSValues+  , JSON(..)++    -- * Encoding and Decoding+  , Result(..)+  , encode -- :: JSON a => a -> String+  , decode -- :: JSON a => String -> Either String a+  , encodeStrict -- :: JSON a => a -> String+  , decodeStrict -- :: JSON a => String -> Either String a++    -- * Wrapper Types+  , JSString+  , toJSString+  , fromJSString++  , JSObject+  , toJSObject+  , fromJSObject+  , resultToEither++    -- * Serialization to and from Strings.+    -- ** Reading JSON+  , readJSNull, readJSBool, readJSString, readJSRational+  , readJSArray, readJSObject, readJSValue++    -- ** Writing JSON+  , showJSNull, showJSBool, showJSRational, showJSArray+  , showJSObject, showJSValue+++  ) where++import Text.JSON.Types+import Text.JSON.String++import Data.Char+import Data.List+import Data.Int+import Data.Word+import Data.Either+import Control.Monad(liftM,ap)+import Control.Applicative++import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.IntSet as I+import qualified Data.Map as M++------------------------------------------------------------------------++-- | Decode a String representing a JSON value +-- (either an object, array, bool, number, null)+--+-- This is a superset of JSON, as types other than+-- Array and Object are allowed at the top level.+--+decode :: (JSON a) => String -> Result a+decode s = case runGetJSON readJSValue s of+             Right a  -> readJSON a+             Left err -> Error err++-- | Encode a Haskell value into a string, in JSON format.+--+-- This is a superset of JSON, as types other than+-- Array and Object are allowed at the top level.+--+encode :: (JSON a) => a -> String+encode = (flip showJSValue [] . showJSON)++------------------------------------------------------------------------++-- | Decode a String representing a strict JSON value.+-- This follows the spec, and requires top level+-- JSON types to be an Array or Object.+decodeStrict :: (JSON a) => String -> Result a+decodeStrict s = case runGetJSON readJSTopType s of+     Right a  -> readJSON a+     Left err -> Error err++-- | Encode a value as a String in strict JSON format.+-- This follows the spec, and requires all values+-- at the top level to be wrapped in either an Array or Object.+-- JSON types to be an Array or Object.+encodeStrict :: (JSON a) => a -> String+encodeStrict = (flip showJSTopType [] . showJSON)++------------------------------------------------------------------------++-- | The class of types serialisable to and from JSON+class JSON a where+  readJSON  :: JSValue -> Result a+  showJSON  :: a -> JSValue++  readJSONs :: JSValue -> Result [a]+  readJSONs (JSArray as) = mapM readJSON as+  readJSONs _            = mkError "Unable to read list"++  showJSONs :: [a] -> JSValue+  showJSONs = JSArray . map showJSON++-- | A type for parser results+data Result a = Ok a | Error String+  deriving (Eq,Show)++-- | Map Results to Eithers+resultToEither :: Result a -> Either String a+resultToEither (Ok a)    = Right a+resultToEither (Error s) = Left  s++instance Functor Result where fmap = liftM++instance Applicative Result where+  (<*>) = ap+  pure  = return++instance Alternative Result where+  Ok a <|> _    = Ok a+  _    <|> Ok b = Ok b+  err  <|> _    = err+  empty         = Error "empty"++instance Monad Result where+  return x      = Ok x+  fail x        = Error x+  Ok a >>= f    = f a+  Error x >>= _ = Error x++-- | Convenient error generation+mkError :: (JSON a) => String -> Result a+mkError s = Error s++--------------------------------------------------------------------+--+-- | To ensure we generate valid JSON, we map Haskell types to JSValue+-- internally, then pretty print that.+--+instance JSON JSValue where+    showJSON = id+    readJSON = return++second :: (a -> b) -> (x,a) -> (x,b)+second f (a,b) = (a, f b)++--------------------------------------------------------------------+-- Some simple JSON wrapper types, to avoid overlapping instances++instance JSON JSString where+  readJSON (JSString s) = return s+  readJSON _            = mkError "Unable to read JSString"+  showJSON = JSString++instance (JSON a) => JSON (JSObject a) where+  readJSON (JSObject o) =+      let f (x,y) = do y' <- readJSON y; return (x,y')+      in toJSObject `fmap` mapM f (fromJSObject o)+  readJSON _ = mkError "Unable to read JSObject"+  showJSON = JSObject . toJSObject . map (second showJSON) . fromJSObject+++-- -----------------------------------------------------------------+-- Instances+--++instance JSON Bool where+  showJSON = JSBool+  readJSON (JSBool b) = return b+  readJSON _          = mkError "Unable to read Bool"++instance JSON Char where+  showJSON  = JSString . toJSString . (:[])+  showJSONs = JSString . toJSString++  readJSON (JSString s) = case fromJSString s of+                            [c] -> return c+                            _ -> mkError "Unable to read Char"+  readJSON _            = mkError "Unable to read Char"++  readJSONs (JSString s)  = return (fromJSString s)+  readJSONs (JSArray a)   = mapM readJSON a+  readJSONs _             = mkError "Unable to read String"++instance JSON Ordering where+  showJSON LT = JSRational (-1)+  showJSON EQ = JSRational 0+  showJSON GT = JSRational 1+  readJSON (JSRational (-1)) = return LT+  readJSON (JSRational 0) = return EQ+  readJSON (JSRational 1) = return GT+  readJSON _ = mkError "Unable to read Ordering"++-- -----------------------------------------------------------------+-- Integral types++instance JSON Integer where+  showJSON = JSRational . fromIntegral+  readJSON (JSRational i) = return $ round i+  readJSON _             = mkError "Unable to read Integer"++-- constrained:+instance JSON Int where+  showJSON = JSRational . fromIntegral+  readJSON (JSRational i) = return $ round i+  readJSON _              = mkError "Unable to read Int"++-- constrained:+instance JSON Word where+  showJSON = JSRational . toRational+  readJSON (JSRational i) = return $ truncate i+  readJSON _             = mkError "Unable to read Word"++-- -----------------------------------------------------------------++instance JSON Word8 where+  showJSON = JSRational . fromIntegral+  readJSON (JSRational i) = return $ truncate i+  readJSON _             = mkError "Unable to read Word8"++instance JSON Word16 where+  showJSON = JSRational . fromIntegral+  readJSON (JSRational i) = return $ truncate i+  readJSON _             = mkError "Unable to read Word16"++instance JSON Word32 where+  showJSON = JSRational . fromIntegral+  readJSON (JSRational i) = return $ truncate i+  readJSON _             = mkError "Unable to read Word32"++instance JSON Word64 where+  showJSON = JSRational . fromIntegral+  readJSON (JSRational i) = return $ truncate i+  readJSON _             = mkError "Unable to read Word64"++instance JSON Int8 where+  showJSON = JSRational . fromIntegral+  readJSON (JSRational i) = return $ truncate i+  readJSON _             = mkError "Unable to read Int8"++instance JSON Int16 where+  showJSON = JSRational . fromIntegral+  readJSON (JSRational i) = return $ truncate i+  readJSON _             = mkError "Unable to read Int16"++instance JSON Int32 where+  showJSON = JSRational . fromIntegral+  readJSON (JSRational i) = return $ truncate i+  readJSON _             = mkError "Unable to read Int32"++instance JSON Int64 where+  showJSON = JSRational . fromIntegral+  readJSON (JSRational i) = return $ truncate i+  readJSON _             = mkError "Unable to read Int64"++-- -----------------------------------------------------------------++instance JSON Double where+  showJSON = JSRational . toRational+  readJSON (JSRational r) = return $ fromRational r+  readJSON _              = mkError "Unable to read Double"+    -- can't use JSRational here, due to ambiguous '0' parse+    -- it will parse as Integer.++instance JSON Float where+  showJSON = JSRational . toRational+  readJSON (JSRational r) = return $ fromRational r+  readJSON _              = mkError "Unable to read Float"++-- -----------------------------------------------------------------+-- Sums++instance (JSON a) => JSON (Maybe a) where+  readJSON (JSObject o) = case "just" `lookup` as of+      Just x -> Just <$> readJSON x+      _      -> case "nothing" `lookup` as of+          Just JSNull -> return Nothing+          _           -> mkError "Unable to read Maybe"+    where as = fromJSObject o+  readJSON _ = mkError "Unable to read Maybe"+  showJSON (Just x) = JSObject $ toJSObject [("just", showJSON x)]+  showJSON Nothing  = JSObject $ toJSObject [("nothing", JSNull)]++instance (JSON a, JSON b) => JSON (Either a b) where+  readJSON (JSObject o) = case "left" `lookup` as of+      Just a  -> Left <$> readJSON a+      Nothing -> case "right" `lookup` as of+          Just b  -> Right <$> readJSON b+          Nothing -> mkError "Unable to read Either"+    where as = fromJSObject o+  readJSON _ = mkError "Unable to read Either"+  showJSON (Left a)  = JSObject $ toJSObject [("left",  showJSON a)]+  showJSON (Right b) = JSObject $ toJSObject [("right", showJSON b)]++-- -----------------------------------------------------------------+-- Products++instance JSON () where+  showJSON _ = JSArray []+  readJSON (JSArray []) = return ()+  readJSON _      = mkError "Unable to read ()"++instance (JSON a, JSON b) => JSON (a,b) where+  showJSON (a,b) = JSArray [ showJSON a, showJSON b ]+  readJSON (JSArray [a,b]) = (,) `fmap` readJSON a `ap` readJSON b+  readJSON _ = mkError "Unable to read Pair"++instance (JSON a, JSON b, JSON c) => JSON (a,b,c) where+  showJSON (a,b,c) = JSArray [ showJSON a, showJSON b, showJSON c ]+  readJSON (JSArray [a,b,c]) = (,,) `fmap`+                                  readJSON a `ap`+                                  readJSON b `ap`+                                  readJSON c+  readJSON _ = mkError "Unable to read Triple"++instance (JSON a, JSON b, JSON c, JSON d) => JSON (a,b,c,d) where+  showJSON (a,b,c,d) = JSArray [showJSON a, showJSON b, showJSON c, showJSON d]+  readJSON (JSArray [a,b,c,d]) = (,,,) `fmap`+                                  readJSON a `ap`+                                  readJSON b `ap`+                                  readJSON c `ap`+                                  readJSON d++  readJSON _ = mkError "Unable to read 4 tuple"++-- -----------------------------------------------------------------+-- List-like types+++instance JSON a => JSON [a] where+  showJSON = showJSONs+  readJSON = readJSONs++instance (Ord a, JSON a, JSON b) => JSON (M.Map a b) where+  showJSON = showJSON . M.toList+  readJSON a@(JSArray _) = M.fromList <$> readJSON a+  readJSON _ = mkError "Unable to read Map"++instance JSON I.IntSet where+  showJSON = showJSON . I.toList+  readJSON a@(JSArray _) = I.fromList <$> readJSON a+  readJSON _ = mkError "Unable to read IntSet"++-- -----------------------------------------------------------------+-- ByteStrings++instance JSON S.ByteString where+  showJSON = JSString . toJSString . S.unpack+  readJSON (JSString s) = return $ S.pack $ fromJSString s+  readJSON _ = mkError "Unable to read ByteString"++instance JSON L.ByteString where+  showJSON = JSString . toJSString . L.unpack+  readJSON (JSString s) = return $ L.pack $ fromJSString s+  readJSON _ = mkError "Unable to read ByteString"

@@ -0,0 +1,118 @@+--------------------------------------------------------------------+-- |+-- Module    : Text.JSON.Parsec+-- Copyright : (c) Galois, Inc. 2007+--+-- Maintainer:  Don Stewart <dons@galois.com>+-- Stability :  provisional+-- Portability: portable+--+-- Parse JSON values using the Parsec combinators.++module Text.JSON.Parsec+  ( p_value+  , p_null+  , p_boolean+  , p_array+  , p_string+  , p_object+  , p_number+  , p_js_string+  , p_js_object+  , module Text.ParserCombinators.Parsec+  ) where++import Text.JSON.Types+import Text.ParserCombinators.Parsec+import Control.Monad+import Data.Char+import Numeric++tok              :: CharParser () a -> CharParser () a+tok p             = spaces *> p++p_value          :: CharParser () JSValue+p_value           =  (JSNull      <$  p_null)+                 <|> (JSBool      <$> p_boolean)+                 <|> (JSArray     <$> p_array)+                 <|> (JSString    <$> p_js_string)+                 <|> (JSObject    <$> p_js_object)+                 <|> (JSRational  <$> p_number)+                 <?> "JSON value"++p_null           :: CharParser () ()+p_null            = tok (string "null") >> return ()++p_boolean        :: CharParser () Bool+p_boolean         = tok+                      (  (True  <$ string "true")+                     <|> (False <$ string "false")+                      )++p_array          :: CharParser () [JSValue]+p_array           = between (tok (char '[')) (tok (char ']'))+                  $ p_value `sepBy` tok (char ',')++p_string         :: CharParser () String+p_string          = between (tok (char '"')) (char '"') (many p_char)+  where p_char    =  (char '\\' >> p_esc)+                 <|> (satisfy (\x -> x /= '"' && x /= '\\'))++        p_esc     =  ('"'   <$ char '"')+                 <|> ('\\'  <$ char '\\')+                 <|> ('/'   <$ char '/')+                 <|> ('\b'  <$ char 'b')+                 <|> ('\f'  <$ char 'f')+                 <|> ('\n'  <$ char 'n')+                 <|> ('\r'  <$ char 'r')+                 <|> ('\t'  <$ char 't')+                 <|> (char 'u' *> p_uni)+                 <?> "escape character"++        p_uni     = check =<< count 4 (satisfy isHexDigit)+          where check x | code <= max_char  = pure (toEnum code)+                        | otherwise         = empty+                  where code      = fst $ head $ readHex x+                        max_char  = fromEnum (maxBound :: Char)++p_object         :: CharParser () [(String,JSValue)]+p_object          = between (tok (char '{')) (tok (char '}'))+                  $ p_field `sepBy` tok (char ',')+  where p_field   = (,) <$> (p_string <* tok (char ':')) <*> p_value++p_number         :: CharParser () Rational+p_number          = do s <- getInput+                       case readSigned readFloat s of+                         [(n,s1)] -> n <$ setInput s1+                         _        -> empty++p_js_string      :: CharParser () JSString+p_js_string       = toJSString <$> p_string++p_js_object      :: CharParser () (JSObject JSValue)+p_js_object       = toJSObject <$> p_object++--------------------------------------------------------------------------------+-- XXX: Because Parsec is not Applicative yet...++pure   :: a -> CharParser () a+pure    = return++(<*>)  :: CharParser () (a -> b) -> CharParser () a -> CharParser () b+(<*>)   = ap++(*>)   :: CharParser () a -> CharParser () b -> CharParser () b+(*>)    = (>>)++(<*)   :: CharParser () a -> CharParser () b -> CharParser () a+m <* n  = do x <- m; n; return x++empty  :: CharParser () a+empty   = mzero++(<$>)  :: (a -> b) -> CharParser () a -> CharParser () b+(<$>)   = fmap++(<$)   :: a -> CharParser () b -> CharParser () a+x <$ m  = m >> return x+

@@ -0,0 +1,69 @@+--------------------------------------------------------------------+-- |+-- Module    : Text.JSON.Pretty+-- Copyright : (c) Galois, Inc. 2007+-- License   : BSD3+--+-- Maintainer:  Don Stewart <dons@galois.com>+-- Stability :  provisional+-- Portability: portable+--+-- Display JSON values using pretty printing combinators.++module Text.JSON.Pretty+  ( module Text.JSON.Pretty+  , module Text.PrettyPrint.HughesPJ+  ) where++import Text.JSON.Types+import Text.PrettyPrint.HughesPJ+import Data.Ratio+import Data.Char+import Numeric++pp_value         :: JSValue -> Doc+pp_value v        = case v of+    JSNull       -> pp_null+    JSBool x     -> pp_boolean x+    JSRational x -> pp_number x+    JSString x   -> pp_js_string x+    JSArray vs   -> pp_array vs+    JSObject xs  -> pp_js_object xs++pp_null          :: Doc+pp_null           = text "null"++pp_boolean       :: Bool -> Doc+pp_boolean True   = text "true"+pp_boolean False  = text "false"++pp_number        :: Rational -> Doc+pp_number x | denominator x == 1  = integer (numerator x)+pp_number x                       = double (fromRational x)++pp_array         :: [JSValue] -> Doc+pp_array xs       = brackets $ fsep $ punctuate comma $ map pp_value xs++pp_string        :: String -> Doc+pp_string x       = doubleQuotes $ hcat $ map pp_char x+  where pp_char '\\'            = text "\\\\"+        pp_char '"'             = text "\\\""+        pp_char c | isControl c = uni_esc c+        pp_char c               = char c++        uni_esc c = text "\\u" <> text (pad 4 (showHex (fromEnum c) ""))++        pad n cs  | len < n   = replicate (n-len) '0' ++ cs+                  | otherwise = cs+          where len = length cs++pp_object        :: [(String,JSValue)] -> Doc+pp_object xs      = braces $ fsep $ punctuate comma $ map pp_field xs+  where pp_field (k,v) = pp_string k <> colon <+> pp_value v++pp_js_string     :: JSString -> Doc+pp_js_string x    = pp_string (fromJSString x)++pp_js_object     :: JSObject JSValue -> Doc+pp_js_object x    = pp_object (fromJSObject x)+

@@ -0,0 +1,117 @@+--------------------------------------------------------------------+-- |+-- Module    : Text.JSON.ReadP+-- Copyright : (c) Galois, Inc. 2007+-- License   : BSD3+--+-- Maintainer:  Don Stewart <dons@galois.com>+-- Stability :  provisional+-- Portability: portable+--+-- Parse JSON values using the ReadP combinators.++module Text.JSON.ReadP+  ( p_value+  , p_null+  , p_boolean+  , p_array+  , p_string+  , p_object+  , p_number+  , p_js_string+  , p_js_object+  , module Text.ParserCombinators.ReadP+  ) where++import Text.JSON.Types+import Text.ParserCombinators.ReadP+import Control.Monad+import Data.Char+import Numeric++token            :: ReadP a -> ReadP a+token p           = skipSpaces *> p++p_value          :: ReadP JSValue+p_value           =  (JSNull      <$  p_null)+                 <|> (JSBool      <$> p_boolean)+                 <|> (JSArray     <$> p_array)+                 <|> (JSString    <$> p_js_string)+                 <|> (JSObject    <$> p_js_object)+                 <|> (JSRational  <$> p_number)++p_null           :: ReadP ()+p_null            = token (string "null") >> return ()++p_boolean        :: ReadP Bool+p_boolean         = token+                      (  (True  <$ string "true")+                     <|> (False <$ string "false")+                      )++p_array          :: ReadP [JSValue]+p_array           = between (token (char '[')) (token (char ']'))+                  $ p_value `sepBy` token (char ',')++p_string         :: ReadP String+p_string          = between (token (char '"')) (char '"') (many p_char)+  where p_char    =  (char '\\' >> p_esc)+                 <|> (satisfy (\x -> x /= '"' && x /= '\\'))++        p_esc     =  ('"'   <$ char '"')+                 <|> ('\\'  <$ char '\\')+                 <|> ('/'   <$ char '/')+                 <|> ('\b'  <$ char 'b')+                 <|> ('\f'  <$ char 'f')+                 <|> ('\n'  <$ char 'n')+                 <|> ('\r'  <$ char 'r')+                 <|> ('\t'  <$ char 't')+                 <|> (char 'u' *> p_uni)++        p_uni     = check =<< count 4 (satisfy isHexDigit)+          where check x | code <= max_char  = pure (toEnum code)+                        | otherwise         = empty+                  where code      = fst $ head $ readHex x+                        max_char  = fromEnum (maxBound :: Char)++p_object         :: ReadP [(String,JSValue)]+p_object          = between (token (char '{')) (token (char '}'))+                  $ p_field `sepBy` token (char ',')+  where p_field   = (,) <$> (p_string <* token (char ':')) <*> p_value++p_number         :: ReadP Rational+p_number          = readS_to_P (readSigned readFloat)++p_js_string      :: ReadP JSString+p_js_string       = toJSString <$> p_string++p_js_object      :: ReadP (JSObject JSValue)+p_js_object       = toJSObject <$> p_object++--------------------------------------------------------------------------------+-- XXX: Because ReadP is not Applicative yet...++pure   :: a -> ReadP a+pure    = return++(<*>)  :: ReadP (a -> b) -> ReadP a -> ReadP b+(<*>)   = ap++(*>)   :: ReadP a -> ReadP b -> ReadP b+(*>)    = (>>)++(<*)   :: ReadP a -> ReadP b -> ReadP a+m <* n  = do x <- m; n; return x++empty  :: ReadP a+empty   = pfail++(<|>)  :: ReadP a -> ReadP a -> ReadP a+(<|>)   = (+++)++(<$>)  :: (a -> b) -> ReadP a -> ReadP b+(<$>)   = fmap++(<$)   :: a -> ReadP b -> ReadP a+x <$ m  = m >> return x+

@@ -0,0 +1,338 @@+--------------------------------------------------------------------+-- |+-- Module    : Text.JSON.String+-- Copyright : (c) Galois, Inc. 2007+-- License   : BSD3+--+-- Maintainer:  Don Stewart <dons@galois.com>+-- Stability :  provisional+-- Portability: portable+--+--------------------------------------------------------------------+--+-- Basic support for working with JSON values.+--++module Text.JSON.String (+    -- * Parsing+    --+     GetJSON, runGetJSON++    -- ** Reading JSON+  , readJSNull, readJSBool, readJSString, readJSRational+  , readJSArray, readJSObject++  , readJSValue, readJSTopType++    -- ** Writing JSON+  , showJSNull, showJSBool, showJSRational, showJSArray+  , showJSObject++  , showJSValue, showJSTopType++  ) where++import Text.JSON.Types++import Data.Char+import Data.List+import Data.Ratio+import Data.Either+import Control.Monad(liftM)+import Numeric+++-- -----------------------------------------------------------------+-- | Parsing JSON++-- | The type of JSON parsers for String+newtype GetJSON a = GetJSON { un :: String -> Either String (a,String) }++instance Functor GetJSON where fmap = liftM+instance Monad GetJSON where+  return x        = GetJSON (\s -> Right (x,s))+  fail x          = GetJSON (\_ -> Left x)+  GetJSON m >>= f = GetJSON (\s -> case m s of+                                     Left err -> Left err+                                     Right (a,s1) -> un (f a) s1)++-- | Run a JSON reader on an input String, returning some Haskell value.+-- All input will be consumed.+runGetJSON :: GetJSON a -> String -> Either String a+runGetJSON (GetJSON m) s = case m s of+     Left err    -> Left err+     Right (a,t) -> case t of+                        [] -> Right a+                        _  -> Left $ "Invalid tokens at end of JSON string: "++ show (take 10 t)++getInput   :: GetJSON String+getInput    = GetJSON (\s -> Right (s,s))++setInput   :: String -> GetJSON ()+setInput s  = GetJSON (\_ -> Right ((),s))++(<$>) :: Functor f => (a -> b) -> f a -> f b+x <$> y = fmap x y++-------------------------------------------------------------------------++-- | Find 8 chars context, for error messages+context :: String -> String+context s = take 8 s++-- | Read the JSON null type+readJSNull :: GetJSON JSValue+readJSNull = do+  xs <- getInput+  if "null" `isPrefixOf` xs+        then setInput (drop 4 xs) >> return JSNull+        else fail $ "Unable to parse JSON null: " ++ context xs++-- | Read the JSON Bool type+readJSBool :: GetJSON JSValue+readJSBool = do+  xs <- getInput+  case () of {_+      | "true"  `isPrefixOf` xs -> setInput (drop 4 xs) >> return (JSBool True)+      | "false" `isPrefixOf` xs -> setInput (drop 5 xs) >> return (JSBool False)+      | otherwise               -> fail $ "Unable to parse JSON Bool: " ++ context xs+  }++-- | Read the JSON String type+readJSString :: GetJSON JSValue+readJSString = do+  x <- getInput+  case x of+       '"' : 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++       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+++-- | Read an Integer or Double in JSON format, returning a Rational+readJSRational :: GetJSON Rational+readJSRational = do+  cs <- getInput+  case cs of+    '-' : 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++        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++        exponent' n (c:cs)+          | c == 'e' || c == 'E' = (n*) <$> exp_num cs+        exponent' n cs = setInput cs >> return n++        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++-- | Read a list in JSON format+readJSArray  :: GetJSON JSValue+readJSArray  = readSequence '[' ']' ',' >>= return . JSArray++-- | Read an object in JSON format+readJSObject :: GetJSON JSValue+readJSObject = readAssocs '{' '}' ',' >>= return . JSObject . toJSObject+++-- | Read a sequence of items+readSequence :: Char -> Char -> Char -> GetJSON [JSValue]+readSequence start end sep = do+  zs <- getInput+  case dropWhile isSpace zs of+    c : cs | c == start ->+        case dropWhile isSpace cs of+            d : ds | d == end -> setInput (dropWhile isSpace ds) >> return []+            ds                -> setInput ds >> parse []+    _ -> fail $ "Unable to parse JSON sequence: sequence stars with invalid character: " ++ context zs++  where parse rs = rs `seq` do+          a  <- readJSValue+          ds <- getInput+          case dropWhile isSpace ds of+            e : es | e == sep -> do setInput (dropWhile isSpace es)+                                    parse (a:rs)+                   | e == end -> do setInput (dropWhile isSpace es)+                                    return (reverse (a:rs))+            _ -> fail $ "Unable to parse JSON array: unterminated array: " ++ context ds+++-- | Read a sequence of JSON labelled fields+readAssocs :: Char -> Char -> Char -> GetJSON [(String,JSValue)]+readAssocs start end sep = do+  zs <- getInput+  case dropWhile isSpace zs of+    c:cs | c == start -> case dropWhile isSpace cs of+            d:ds | d == end -> setInput (dropWhile isSpace ds) >> return []+            ds              -> setInput ds >> parsePairs []+    _ -> fail "Unable to parse JSON object: unterminated object"++  where parsePairs rs = rs `seq` do+          a  <- do k  <- do x <- readJSString ; case x of+                                JSString s -> return 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)+                       _      -> fail $ "Malformed JSON labelled field: " ++ context ds++          ds <- getInput+          case dropWhile isSpace ds of+            e : es | e == sep -> do setInput (dropWhile isSpace es)+                                    parsePairs (a:rs)+                   | e == end -> do setInput (dropWhile isSpace es)+                                    return (reverse (a:rs))+            _ -> fail $ "Unable to parse JSON object: unterminated sequence: "+                            ++ context ds++-- | Read one of several possible JS types+readJSValue :: GetJSON JSValue+readJSValue = do+  cs <- getInput+  case cs of+    '"' : _ -> readJSString+    '[' : _ -> readJSArray+    '{' : _ -> readJSObject+    't' : _ -> readJSBool+    'f' : _ -> readJSBool+    xs    | "null" `isPrefixOf` xs -> readJSNull+    (x:_) | x == '-' || isDigit x  -> JSRational <$> readJSRational++    xs -> fail $ "Malformed JSON: invalid token in this context " ++ context xs++-- | Top level JSON can only be Arrays or Objects+readJSTopType :: GetJSON JSValue+readJSTopType = do+  cs <- getInput+  case cs of+    '[' : _ -> readJSArray+    '{' : _ -> readJSObject+    _       -> fail "Invalid JSON: a JSON text a serialized object or array at the top level."++-- -----------------------------------------------------------------+-- | Writing JSON++-- | Show strict JSON top level types. Values not permitted+-- at the top level are wrapped in a singleton array.+showJSTopType :: JSValue -> ShowS+showJSTopType (JSArray a)    = showJSArray a+showJSTopType (JSObject o)   = showJSObject o+showJSTopType x              = showJSTopType $ JSArray [x]++-- | Show JSON values+showJSValue :: JSValue -> ShowS+showJSValue (JSNull)       = showJSNull+showJSValue (JSBool b)     = showJSBool b+showJSValue (JSRational r) = showJSRational r+showJSValue (JSArray a)    = showJSArray a+showJSValue (JSString s)   = showJSString s+showJSValue (JSObject o)   = showJSObject o++-- | Write the JSON null type+showJSNull :: ShowS+showJSNull = showString "null"++-- | Write the JSON Bool type+showJSBool :: Bool -> ShowS+showJSBool True  = showString "true"+showJSBool False = showString "false"++-- | Write the JSON String type+showJSString :: JSString -> ShowS+showJSString x = quote . foldr (.) quote (map sh (fromJSString x))+  where+        quote = showChar '"'+        sh c  = case c of+                  '"'  -> showString "\\\""+                  '\\' -> showString "\\\\"+                  '\n' -> showString "\\n"+                  '\r' -> showString "\\r"+                  '\t' -> showString "\\t"+                  '\f' -> showString "\\f"+                  '\b' -> showString "\\b"+                  _ | n < 32 -> showString "\\u"+                       . showHex d1 . showHex d2 . showHex d3 . showHex d4+                  _ -> showChar c+          where n = fromEnum c+                (d1,n1) = n  `divMod` 0x1000+                (d2,n2) = n1 `divMod` 0x0100+                (d3,d4) = n2 `divMod` 0x0010++-- | Show a Rational in JSON format+showJSRational :: Rational -> ShowS+showJSRational r | denominator r == 1 = shows $ numerator r+                 | otherwise = if isInfinite x || isNaN x then showJSNull+                                                          else shows x+                     where x :: Double+                           x = realToFrac r++-- | Show a list in JSON format+showJSArray :: [JSValue] -> ShowS+showJSArray = showSequence '[' ']' ','++-- | Show an association list in JSON format+showJSObject :: JSObject JSValue -> ShowS+showJSObject = showAssocs '{' '}' ',' . fromJSObject++-- | Show a generic sequence of pairs in JSON format+showAssocs :: Char -> Char -> Char -> [(String,JSValue)] -> ShowS+showAssocs start end sep xs rest = (start:[])+    ++ concat (intersperse (sep:[]) $ map mkRecord xs)+    ++ (end:[]) ++ rest+  where mkRecord (k,v) = show k ++ ":" ++ showJSValue v []++-- | Show a generic sequence in JSON format+showSequence :: Char -> Char -> Char -> [JSValue] -> ShowS+showSequence start end sep xs rest = (start:[])+  ++ concat (intersperse (sep:[]) $ map (flip showJSValue []) xs)+  ++ (end:[]) ++ rest+

@@ -0,0 +1,81 @@+--------------------------------------------------------------------+-- |+-- Module    : Text.JSON.Types+-- Copyright : (c) Galois, Inc. 2007+-- License   : BSD3+--+-- Maintainer:  Don Stewart <dons@galois.com>+-- Stability :  provisional+-- Portability: portable+--+--------------------------------------------------------------------+--+-- Basic support for working with JSON values.+--++module Text.JSON.Types (++    -- * JSON Types+    JSValue(..)++    -- * Wrapper Types+  , JSString(..)+  , toJSString+  , fromJSString++  , JSObject(..)+  , toJSObject+  , fromJSObject++  ) where++import Data.Char+import Data.Ratio++--+-- | JSON values+--+-- The type to which we encode Haskell values. There's a set+-- of primitives, and a couple of heterogenous collection types.+--+-- Objects:+--+-- An object structure is represented as a pair of curly brackets+-- surrounding zero or more name\/value pairs (or members).  A name is a+-- string.  A single colon comes after each name, separating the name+-- from the value.  A single comma separates a value from a+-- following name.+--+-- Arrays:+--+-- An array structure is represented as square brackets surrounding+-- zero or more values (or elements).  Elements are separated by commas.+--+-- Only valid JSON can be constructed this way+--+data JSValue+    = JSNull+    | JSBool     !Bool+    | JSRational !Rational+    | JSString   JSString+    | JSArray    [JSValue]+    | JSObject   (JSObject JSValue)+    deriving (Show, Read, Eq, Ord)++-- | Strings can be represented a little more efficiently in JSON+newtype JSString   = JSONString { fromJSString :: String }+    deriving (Eq, Ord, Show, Read)++-- | Turn a Haskell string into a JSON string.+toJSString :: String -> JSString+toJSString = JSONString++-- | As can association lists+newtype JSObject e = JSONObject { fromJSObject :: [(String, e)] }+    deriving (Eq, Ord, Show, Read)++-- | Make JSON object out of an association list.+toJSObject :: [(String,a)] -> JSObject a+toJSObject = JSONObject++

@@ -0,0 +1,91 @@+name:               json+version:            0.3.3+synopsis:           Support for serialising Haskell to and from JSON+description:+    JSON (JavaScript Object Notation) is a lightweight data-interchange+    format. It is easy for humans to read and write. It is easy for+    machines to parse and generate.  It is based on a subset of the+    JavaScript Programming Language, Standard ECMA-262 3rd Edition -+    December 1999.+    .+    This library provides a parser and pretty printer for converting+    between Haskell values and JSON.+category:           Web+license:            BSD3+license-file:       LICENSE+author:             Galois Inc.+maintainer:         dons@galois.com+Copyright:          (c) 2007-2008 Galois Inc.+cabal-version:      >= 1.2.0+build-type: Simple+extra-source-files:+    tests/HUnit.hs+    tests/Makefile+    tests/Parallel.hs+    tests/QC.hs+    tests/QuickCheckUtils.hs+    tests/Unit.hs+    tests/unit/fail1.json+    tests/unit/fail10.json+    tests/unit/fail11.json+    tests/unit/fail12.json+    tests/unit/fail13.json+    tests/unit/fail14.json+    tests/unit/fail15.json+    tests/unit/fail16.json+    tests/unit/fail17.json+    tests/unit/fail18.json+    tests/unit/fail19.json+    tests/unit/fail2.json+    tests/unit/fail20.json+    tests/unit/fail21.json+    tests/unit/fail22.json+    tests/unit/fail23.json+    tests/unit/fail24.json+    tests/unit/fail25.json+    tests/unit/fail26.json+    tests/unit/fail27.json+    tests/unit/fail28.json+    tests/unit/fail29.json+    tests/unit/fail3.json+    tests/unit/fail30.json+    tests/unit/fail31.json+    tests/unit/fail32.json+    tests/unit/fail33.json+    tests/unit/fail4.json+    tests/unit/fail5.json+    tests/unit/fail6.json+    tests/unit/fail7.json+    tests/unit/fail8.json+    tests/unit/fail9.json+    tests/unit/pass1.json+    tests/unit/pass2.json+    tests/unit/pass3.json++flag split-base+  default: True+  description: Use the new split base package.+flag parsec+  default: True+  description: Add support for parsing with Parsec.+flag pretty+  default: True+  description: Add support for using pretty printing combinators.++library+  exposed-modules: Text.JSON,+                   Text.JSON.Types,+                   Text.JSON.String,+                   Text.JSON.ReadP+  ghc-options:     -Wall -O2++  if flag(split-base)+    build-depends:   base >= 3, array, containers, bytestring+    if flag(parsec)+      build-depends:    parsec+      exposed-modules:  Text.JSON.Parsec+    if flag(pretty)+      build-depends:    pretty+      exposed-modules:  Text.JSON.Pretty+  else+    build-depends:    base < 3

@@ -0,0 +1,82 @@+{-# OPTIONS -fglasgow-exts #-}++import Text.JSON+import Test.HUnit+import System.Exit (exitFailure)+import Control.Monad (when)+import System.IO+import Data.Either+import qualified Data.Map as M++isError (Error _) = True+isError _        = False+++main = do counts <- runTestTT tests+          when (errors counts > 0 || failures counts > 0) exitFailure++tests = TestList+    [shouldFail "non-array top level"         "fail1" (undefined :: String)+    ,shouldFail "unclosed array"              "fail2" (undefined :: JSValue)+    ,shouldFail "object keys must be quoted"  "fail3" (undefined :: JSValue)+    ,shouldFail "extra comma"                 "fail4" (undefined :: JSValue)+    ,shouldFail "double extra comma"          "fail5" (undefined :: JSValue)+    ,shouldFail "missing value"               "fail6" (undefined :: JSValue)+    ,shouldFail "comma after close"           "fail7" (undefined :: JSValue)+    ,shouldFail "extra close"                 "fail8" (undefined :: JSValue)+    ,shouldFail "extra comma"                 "fail9" (undefined :: JSValue)+    ,shouldFail "extra value"                 "fail10" (undefined :: JSValue)+    ,shouldFail "illegal expression"          "fail11" (undefined :: JSValue)+    ,shouldFail "illegal expression"          "fail12" (undefined :: JSValue)+    ,shouldFail "numbers with leading zeroes" "fail13" (undefined :: JSValue)+    ,shouldFail "numbers in hex"              "fail14" (undefined :: JSValue)+    ,shouldFail "illegal backslash"           "fail15" (undefined :: JSValue)+    ,shouldFail "unquoted char"               "fail16" (undefined :: JSValue)+    ,shouldFail "illegal escape"              "fail17" (undefined :: JSValue)+    ,shouldPass "deep objects"                "fail18" (undefined :: JSValue)  -- depth is allowed to be limited, but why bother?+    ,shouldFail "missing colon"               "fail19" (undefined :: JSValue)+    ,shouldFail "double colon"                "fail20" (undefined :: JSValue)+    ,shouldFail "comma instead of colon"      "fail21" (undefined :: JSValue)+    ,shouldFail "colon intead of comma"       "fail22" (undefined :: JSValue)+    ,shouldFail "invalid token"               "fail23" (undefined :: JSValue)+    ,shouldFail "single quotes"               "fail24" (undefined :: JSValue)+    ,shouldFail "literal tabs"                "fail25" (undefined :: JSValue)+    ,shouldFail "tabs in strings"             "fail26" (undefined :: JSValue)+    ,shouldFail "newline in strings"          "fail27" (undefined :: JSValue)+    ,shouldFail "escaped newline in strings"  "fail28" (undefined :: JSValue)+    ,shouldFail "funny number"                "fail29" (undefined :: JSValue)+    ,shouldFail "funny number 2"              "fail30" (undefined :: JSValue)+    ,shouldFail "funny number 3"              "fail31" (undefined :: JSValue)+    ,shouldFail "unterminated array"          "fail32" (undefined :: JSValue)+    ,shouldFail "unterminated array"          "fail33" (undefined :: JSValue)++    , shouldPass "complex valid input 1"        "pass1"  (undefined :: JSValue)+    , shouldPass "complex valid input 2"        "pass2"  (undefined :: JSValue)+    , shouldPass "complex valid input 3"        "pass3"  (undefined :: JSValue)+    ]++------------------------------------------------------------------------++load n = readFile ("unit/" ++ n ++ ".json")++shouldFail :: JSON a => String -> String -> a -> Test+shouldFail  s n (x :: a) = TestLabel ("Should fail: " ++ s) $+  TestCase $ do+--  hPutStrLn stderr $ ("\t\tShould fail: " ++ s)+    s <- load n+    assert =<< case decodeStrict s :: Result a of+                    Ok _     -> return False+                    Error  s -> -- do hPrint stderr s+                                   return True+++shouldPass :: JSON a => String -> String -> a -> Test+shouldPass  s n (x :: a) = TestLabel ("Should pass: " ++ s) $+  TestCase $ do+--  hPutStrLn stderr $ ("\t\tShould pass: " ++ s)+    s <- load n+    assert =<< case decodeStrict s :: Result a of+                    Ok _     -> return True+                    Error  s -> do hPrint stderr s+                                   return False+

@@ -0,0 +1,13 @@+ODIR=.ghc++$(ODIR):+	mkdir $(ODIR)++all: $(ODIR)+	ghc -cpp -O QC.hs --make -o QC -no-recomp -odir=$(ODIR) -hidir=$(ODIR)+	time ./QC+	runhaskell HUnit.hs++clean:+	$(RM) -r $(ODIR)+	$(RM) *.html *.tix QC

@@ -0,0 +1,151 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Test.QuickCheck.Parallel+-- Copyright   :  (c) Don Stewart 2006+-- License     :  BSD-style (see the file LICENSE)+-- +-- Maintainer  :  dons@cse.unsw.edu.au+-- Stability   :  experimental+-- Portability :  non-portable (uses Control.Exception, Control.Concurrent)+--+-- A parallel batch driver for running QuickCheck on threaded or SMP systems.+-- See the /Example.hs/ file for a complete overview.+--++module Parallel (+    pRun,+    pDet,+    pNon+  ) where++import Test.QuickCheck+import Data.List+import Control.Concurrent (forkIO)++import Control.Concurrent.Chan+import Control.Concurrent.MVar++import Control.Exception  hiding (evaluate)+import System.Random+import System.IO          (hFlush,stdout)+import Text.Printf++type Name   = String+type Depth  = Int+type Test   = (Name, Depth -> IO String)++-- | Run a list of QuickCheck properties in parallel chunks, using+-- 'n' Haskell threads (first argument), and test to a depth of 'd'+-- (second argument). Compile your application with '-threaded' and run+-- with the SMP runtime's '-N4' (or however many OS threads you want to+-- donate), for best results.+--+-- > import Test.QuickCheck.Parallel+-- >+-- > do n <- getArgs >>= readIO . head+-- >    pRun n 1000 [ ("sort1", pDet prop_sort1) ]+--+-- Will run 'n' threads over the property list, to depth 1000.+--+pRun :: Int -> Int -> [Test] -> IO ()+pRun n depth tests = do+    chan <- newChan+    ps   <- getChanContents chan+    work <- newMVar tests++    forM_ [1..n] $ forkIO . thread work chan++    let wait xs i+            | i >= n     = return () -- done+            | otherwise = case xs of+                    Nothing : xs -> wait xs $! i+1+                    Just s  : xs -> putStr s >> hFlush stdout >> wait xs i+    wait ps 0++  where+    thread :: MVar [Test] -> Chan (Maybe String) -> Int -> IO ()+    thread work chan me = loop+      where+        loop = do+            job <- modifyMVar work $ \jobs -> return $ case jobs of+                        []     -> ([], Nothing)+                        (j:js) -> (js, Just j)+            case job of+                Nothing          -> writeChan chan Nothing -- done+                Just (name,prop) -> do+                    v <- prop depth+                    writeChan chan . Just $ printf "%d: %-25s: %s" me name v+                    loop+++-- | Wrap a property, and run it on a deterministic set of data+pDet :: Testable a => a -> Int -> IO String+pDet a n = mycheck Det defaultConfig+    { configMaxTest = n+    , configEvery   = \n args -> unlines args } a++-- | Wrap a property, and run it on a non-deterministic set of data+pNon :: Testable a => a -> Int -> IO String+pNon a n = mycheck NonDet defaultConfig+    { configMaxTest = n+    , configEvery   = \n args -> unlines args } a++data Mode = Det | NonDet++------------------------------------------------------------------------++mycheck :: Testable a => Mode -> Config -> a -> IO String+mycheck Det config a = do+     let rnd = mkStdGen 99  -- deterministic+     mytests config (evaluate a) rnd 0 0 []++mycheck NonDet config a = do+    rnd <- newStdGen        -- different each run+    mytests config (evaluate a) rnd 0 0 []++mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO String+mytests config gen rnd0 ntest nfail stamps+  | ntest == configMaxTest config = do done "OK," ntest stamps+  | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps+  | otherwise = do+         case ok result of+           Nothing    ->+             mytests config gen rnd1 ntest (nfail+1) stamps+           Just True  ->+             mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)+           Just False ->+             return ( "Falsifiable after "+                   ++ show ntest+                   ++ " tests:\n"+                   ++ unlines (arguments result)+                    )+     where+      result      = generate (configSize config ntest) rnd2 gen+      (rnd1,rnd2) = split rnd0++done :: String -> Int -> [[String]] -> IO String+done mesg ntest stamps =+    return ( mesg ++ " " ++ show ntest ++ " tests" ++ table )+  where+    table = display+        . map entry+        . reverse+        . sort+        . map pairLength+        . group+        . sort+        . filter (not . null)+        $ stamps++    display []  = ".\n"+    display [x] = " (" ++ x ++ ").\n"+    display xs  = ".\n" ++ unlines (map (++ ".") xs)++    pairLength xss@(xs:_) = (length xss, xs)+    entry (n, xs)         = percentage n ntest+                          ++ " "+                          ++ concat (intersperse ", " xs)++    percentage n m        = show ((100 * n) `div` m) ++ "%"++forM_ = flip mapM_

@@ -0,0 +1,192 @@+{-# OPTIONS_GHC -fglasgow-exts  #-}+module Main where++import Text.JSON++import Parallel++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet++import qualified Control.Exception as C (catch,evaluate)+import Control.Monad+import Foreign+import System.Environment+import System.IO+import System.IO.Unsafe+import Data.Word+import Data.Int++import Test.QuickCheck hiding (test)+import QuickCheckUtils+import Debug.Trace+import Text.Printf++import Data.IntSet          ( IntSet )+import qualified Data.ByteString      as S+import qualified Data.ByteString.Lazy as L+import qualified Data.Sequence as Seq+import qualified Data.Map as M+import qualified Data.IntMap as I++------------------------------------------------------------------------+-- low level ones:++main :: IO ()+main = do+    hSetBuffering stdout NoBuffering+    s <- getArgs+    let n = if null s then 100 else read (head s)+        k = doIt n++    k basics+    k atomicCharacterTypes+    k numbers+    k listlikes+    k containers+    k sumtypes+    k products+++doIt n (s,x) = putStrLn (" *** " ++ s) >> pRun 2 n x+++type T a = a -> Property+type B a = a -> Bool++p :: Testable a => a -> Int -> IO String+p = pNon++test :: forall a. (Show a,Arbitrary a, Eq a, JSON a) => a -> Property+test _ = forAll (arbitrary :: Gen a) $ \a ->+                Ok a == decode (encode a)++instance Arbitrary JSString where+    arbitrary = liftM toJSString arbitrary+    coarbitrary = undefined++instance (Ord e, Arbitrary e) => Arbitrary (JSObject e) where+    arbitrary   = do+            ks <- arbitrary+            vs <- arbitrary+            return . toJSObject . M.toList . M.fromList . zip ks $ vs++    coarbitrary = undefined++------------------------------------------------------------------------++-- tests :: [(String, Int -> IO String)]+basics = ("Basic types",+                [("Bool",        p (test :: T Bool ))+                ,("()",          p (test :: T () ))+                ]+         )++        -- atomic character types++atomicCharacterTypes =+    ("Atomic string types",++    [("String",      p (test :: T JSString  ))+    ,("Strict ByteString",       p (test :: T S.ByteString ))+    ,("Lazy ByteString",         p (test :: T L.ByteString ))+    ,("Char",        p (test :: T Char ))+    ]+    )++        -- basic numeric types+numbers =+    ("Numeric types",+        [("Integer",     p (test :: T Integer ))+        ,("Int",         p (test :: T Int ))+        ,("Word",        p (test :: T Word ))++        -- words++        ,("Word8",        p (test :: T Word8    ))+        ,("Word16",       p (test :: T Word16   ))+        ,("Word32",       p (test :: T Word32   ))+        ,("Word64",       p (test :: T Word64   ))++        -- integers++        ,("Int8",         p (test :: T Int8     ))+        ,("Int16",        p (test :: T Int16    ))+        ,("Int32",        p (test :: T Int32    ))+        ,("Int64",        p (test :: T Int64    ))++        -- rationals++        ,("Double",         p (test :: T Double))+        ,("Float",          p (test :: T Float))+    ])++        -- lists++listlikes =+    ("List like types",+        [("[()]",           p (test :: T [()]))+        ,("[Int]",          p (test :: T [Int]))+        ,("[Bool]",         p (test :: T [Bool]))+        ,("[Integer]",      p (test :: T [Integer]))+        ,("[Int]",          p (test :: T [Int]))+        ,("[Word]",         p (test :: T [Word]))+        ,("[S.ByteString]", p (test :: T [S.ByteString]               ))+        ,("[L.ByteString]", p (test :: T [L.ByteString]               ))++    ])+        -- containers++containers =+    ("Container types",+        [("IntSet",         p (test :: T IntSet ))+        ,("Map String Int", p (test :: T (M.Map String Int)      ))+        ,("Map Int String", p (test :: T (M.Map Int String)      ))++--      ,("Maybe Bool",  p (test :: T (Maybe Bool) ))+--      ,("Rational",   p (test :: T Rational ))++        ]+    )++sumtypes =+    ("Sum types",+        [("Ordering",         p (test :: T Ordering))+        ,("Maybe Int",        p (test :: T (Maybe Int)))+        ,("Maybe String",        p (test :: T (Maybe String)))+        ,("Either Bool String",        p (test :: T (Either Bool String)))+        ,("Either Int (Either Int Word32)",+                    p (test :: T (Either Int (Either Int Word32))))+    ])++products =+    ("Products",+        [("((),())",+            p (test :: T ((),())+         ))++        ,("(Bool,Int)",+            p (test :: T (Bool,Int)+            ))++        ,("(Bool,(Int, String))",+            p (test :: T (Bool,(Int,String))+            ))++        ,("(Maybe String,(Either Int Bool, String))",+            p (test :: T (Bool,(Either Int Bool,String))+            ))++        ,("(Bool,Int,String)",+            p (test :: T (Bool,Int,String)+            ))++        ,("(Bool,Int,String,Char)",+            p (test :: T (Bool,Int,String,Char)+            ))++         ]++    )

@@ -0,0 +1,272 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+--+-- Uses multi-param type classes+--+module QuickCheckUtils where++import Control.Monad++import Test.QuickCheck.Batch+import Test.QuickCheck+import Text.Show.Functions+import Data.Ratio++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet++import qualified Control.Exception as C (evaluate)++import Control.Monad        ( liftM2 )+import Data.Char+import Data.List+import Data.Word+import Data.Int+import System.Random+import System.IO++-- import Control.Concurrent+import System.Mem+import System.CPUTime+import Text.Printf++import qualified Data.ByteString      as P+import qualified Data.ByteString.Lazy as L++#if __GLASGOW_HASKELL__ >= 608+import qualified Data.ByteString.Lazy.Internal as L+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Internal as B+#else+import qualified Data.ByteString.Base as B+#endif++-- import qualified Data.Sequence as Seq++-- Enable this to get verbose test output. Including the actual tests.+debug = False++mytest :: Testable a => a -> Int -> IO ()+mytest a n = mycheck defaultConfig+    { configMaxTest=n+    , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a++mycheck :: Testable a => Config -> a -> IO ()+mycheck config a = do+     rnd <- newStdGen+     performGC -- >> threadDelay 100+     t <- mytests config (evaluate a) rnd 0 0 [] 0 -- 0+     printf " %0.3f seconds\n" (t :: Double)+     hFlush stdout++time :: a -> IO (a , Double)+time a = do+    start <- getCPUTime+    v     <- C.evaluate a+    v `seq` return ()+    end   <- getCPUTime+    return (v,     (      (fromIntegral (end - start)) / (10^12)))++mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> Double -> IO  Double+mytests config gen rnd0 ntest nfail stamps t0+  | ntest == configMaxTest config = do done "OK," ntest stamps+                                       return t0++  | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps+                                       return t0++  | otherwise = do+     (result,t1) <- time (generate (configSize config ntest) rnd2 gen)++     putStr (configEvery config ntest (arguments result)) >> hFlush stdout+     case ok result of+       Nothing    ->+         mytests config gen rnd1 ntest (nfail+1) stamps (t0 + t1)+       Just True  ->+         mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) (t0 + t1)+       Just False -> do+         putStr ( "Falsifiable after "+               ++ show ntest+               ++ " tests:\n"+               ++ unlines (arguments result)+                ) >> hFlush stdout+         return t0++     where+      (rnd1,rnd2) = split rnd0++done :: String -> Int -> [[String]] -> IO ()+done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )+ where+  table = display+        . map entry+        . reverse+        . sort+        . map pairLength+        . group+        . sort+        . filter (not . null)+        $ stamps++  display []  = ". "+  display [x] = " (" ++ x ++ "). "+  display xs  = ".\n" ++ unlines (map (++ ".") xs)++  pairLength xss@(xs:_) = (length xss, xs)+  entry (n, xs)         = percentage n ntest+                       ++ " "+                       ++ concat (intersperse ", " xs)++  percentage n m        = show ((100 * n) `div` m) ++ "%"++------------------------------------------------------------------------++instance Random Word8 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Int8 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Word16 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Int16 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Word where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Word32 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Int32 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Word64 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Int64 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++------------------------------------------------------------------------++integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)+integralRandomR  (a,b) g = case randomR (fromIntegral a :: Integer,+                                         fromIntegral b :: Integer) g of+                            (x,g) -> (fromIntegral x, g)++------------------------------------------------------------------------++instance Arbitrary Word8 where+    arbitrary       = choose (0, 2^8-1)+    coarbitrary w   = variant 0++instance Arbitrary (Ratio Integer) where+    arbitrary       = do n <- arbitrary+                         m <- arbitrary+                         if m /= 0+                                then return (n % m)+                                else arbitrary+    coarbitrary w   = undefined++instance Arbitrary Word16 where+    arbitrary       = choose (0, 2^16-1)+    coarbitrary     = undefined++instance Arbitrary Word32 where+--  arbitrary       = choose (0, 2^32-1)+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Word64 where+--  arbitrary       = choose (0, 2^64-1)+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Int8 where+--  arbitrary       = choose (0, 2^8-1)+    arbitrary       = choose (minBound, maxBound)+    coarbitrary w   = variant 0++instance Arbitrary Int16 where+--  arbitrary       = choose (0, 2^16-1)+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Int32 where+--  arbitrary       = choose (0, 2^32-1)+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Int64 where+--  arbitrary       = choose (0, 2^64-1)+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Word where+    arbitrary       = choose (minBound, maxBound)+    coarbitrary w   = variant 0++------------------------------------------------------------------------++instance Arbitrary Char where+    arbitrary = choose (maxBound, minBound)+    coarbitrary = undefined++{-+instance Arbitrary a => Arbitrary (Maybe a) where+    arbitrary = oneof [ return Nothing, liftM Just arbitrary]+    coarbitrary = undefined+    -}++instance Arbitrary Ordering where+    arbitrary = oneof [ return LT,return  GT,return  EQ ]+    coarbitrary = undefined++{-+instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where+    arbitrary = oneof [ liftM Left arbitrary, liftM Right arbitrary]+    coarbitrary = undefined+    -}++instance Arbitrary IntSet.IntSet where+    arbitrary = fmap IntSet.fromList arbitrary+    coarbitrary = undefined++instance (Arbitrary e) => Arbitrary (IntMap.IntMap e) where+    arbitrary = fmap IntMap.fromList arbitrary+    coarbitrary = undefined++instance (Arbitrary a, Ord a) => Arbitrary (Set.Set a) where+    arbitrary = fmap Set.fromList arbitrary+    coarbitrary = undefined++instance (Arbitrary a, Ord a, Arbitrary b) => Arbitrary (Map.Map a b) where+    arbitrary = fmap Map.fromList arbitrary+    coarbitrary = undefined++{-+instance (Arbitrary a) => Arbitrary (Seq.Seq a) where+    arbitrary = fmap Seq.fromList arbitrary+    coarbitrary = undefined+-}++instance Arbitrary L.ByteString where+    arbitrary     = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant.+    coarbitrary s = coarbitrary (L.unpack s)++instance Arbitrary B.ByteString where+  arbitrary = B.pack `fmap` arbitrary+  coarbitrary s = coarbitrary (B.unpack s)

@@ -0,0 +1,12 @@++import Text.JSON+import Network.RPC.JSON+import System.Exit++main = do+    case (decode test1 :: Result JSRequest) of+         Ok _ -> exitWith ExitSuccess+++test1 = +    "{\"method\":\"feed.add\",\"params\":{\"uri\":\"http://rss.slashdot.org/Slashdot/slashdot\"},\"version\":\"1.1\" }"

@@ -0,0 +1,1 @@+"A JSON payload should be an object or array, not a string."

@@ -0,0 +1,1 @@+{"Extra value after close": true} "misplaced quoted value"

@@ -0,0 +1,1 @@+{"Illegal expression": 1 + 2}

@@ -0,0 +1,1 @@+{"Illegal invocation": alert()}

@@ -0,0 +1,1 @@+{"Numbers cannot have leading zeroes": 013}

@@ -0,0 +1,1 @@+{"Numbers cannot be hex": 0x14}

@@ -0,0 +1,1 @@+["Illegal backslash escape: \x15"]

@@ -0,0 +1,1 @@+[\naked]

@@ -0,0 +1,1 @@+["Illegal backslash escape: \017"]

@@ -0,0 +1,1 @@+[[[[[[[[[[[[[[[[[[[["Too deep"]]]]]]]]]]]]]]]]]]]]

@@ -0,0 +1,1 @@+{"Missing colon" null}

@@ -0,0 +1,1 @@+["Unclosed array"

@@ -0,0 +1,1 @@+{"Double colon":: null}

@@ -0,0 +1,1 @@+{"Comma instead of colon", null}

@@ -0,0 +1,1 @@+["Colon instead of comma": false]

@@ -0,0 +1,1 @@+["Bad value", truth]

@@ -0,0 +1,1 @@+['single quote']

@@ -0,0 +1,1 @@+["	tab	character	in	string	"]

@@ -0,0 +1,1 @@+["tab\   character\   in\  string\  "]

@@ -0,0 +1,2 @@+["line+break"]

@@ -0,0 +1,2 @@+["line\+break"]

@@ -0,0 +1,1 @@+[0e]

@@ -0,0 +1,1 @@+{unquoted_key: "keys must be quoted"}

@@ -0,0 +1,1 @@+[0e+]

@@ -0,0 +1,1 @@+[0e+-1]

@@ -0,0 +1,1 @@+{"Comma instead if closing brace": true,

@@ -0,0 +1,1 @@+["mismatch"}

@@ -0,0 +1,1 @@+["extra comma",]

@@ -0,0 +1,1 @@+["double extra comma",,]

@@ -0,0 +1,1 @@+[   , "<-- missing value"]

@@ -0,0 +1,1 @@+["Comma after the close"],

@@ -0,0 +1,1 @@+["Extra close"]]

@@ -0,0 +1,1 @@+{"Extra comma": true,}

@@ -0,0 +1,58 @@+[+    "JSON Test Pattern pass1",+    {"object with 1 member":["array with 1 element"]},+    {},+    [],+    -42,+    true,+    false,+    null,+    {+        "integer": 1234567890,+        "real": -9876.543210,+        "e": 0.123456789e-12,+        "E": 1.234567890E+34,+        "":  23456789012E66,+        "zero": 0,+        "one": 1,+        "space": " ",+        "quote": "\"",+        "backslash": "\\",+        "controls": "\b\f\n\r\t",+        "slash": "/ & \/",+        "alpha": "abcdefghijklmnopqrstuvwyz",+        "ALPHA": "ABCDEFGHIJKLMNOPQRSTUVWYZ",+        "digit": "0123456789",+        "0123456789": "digit",+        "special": "`1~!@#$%^&*()_+-={':[,]}|;.</>?",+        "hex": "\u0123\u4567\u89AB\uCDEF\uabcd\uef4A",+        "true": true,+        "false": false,+        "null": null,+        "array":[  ],+        "object":{  },+        "address": "50 St. James Street",+        "url": "http://www.JSON.org/",+        "comment": "// /* <!-- --",+        "# -- --> */": " ",+        " s p a c e d " :[1,2 , 3++,++4 , 5        ,          6           ,7        ],"compact":[1,2,3,4,5,6,7],+        "jsontext": "{\"object with 1 member\":[\"array with 1 element\"]}",+        "quotes": "&#34; \u0022 %22 0x22 034 &#x22;",+        "\/\\\"\uCAFE\uBABE\uAB98\uFCDE\ubcda\uef4A\b\f\n\r\t`1~!@#$%^&*()_+-=[]{}|;:',./<>?"+: "A key can be any string"+    },+    0.5 ,98.6+,+99.44+,++1066,+1e1,+0.1e1,+1e-1,+1e00,2e+00,2e-00+,"rosebud"]

@@ -0,0 +1,1 @@+[[[[[[[[[[[[[[[[[[["Not too deep"]]]]]]]]]]]]]]]]]]]

@@ -0,0 +1,6 @@+{+    "JSON Test Pattern pass3": {+        "The outermost value": "must be an object or array.",+        "In this test": "It is an object."+    }+}