json 0.3.6 → 0.4.1

raw patch · 11 files changed

+532/−111 lines, 11 filesdep +mtldep +sybdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, syb

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGES +21/−0
• Text/JSON.hs +146/−72
• Text/JSON/Generic.hs +208/−0
• Text/JSON/Parsec.hs +3/−3
• Text/JSON/Pretty.hs +7/−6
• Text/JSON/ReadP.hs +3/−3
• Text/JSON/String.hs +35/−18
• Text/JSON/Types.hs +4/−4
• json.cabal +18/−3
• tests/GenericTest.hs +81/−0
• tests/Makefile +6/−2

@@ -0,0 +1,21 @@++Version 0.4.1: released 2009-01-12; changes from 0.3.6++  * Addition of extra JSON instances:+       - IntMap, Set, Array, IntSet+       +  * Dropped initial letter case-lowering for constructors: +       - Maybe's constructors are mapped to "Nothing","Just".+       - Either's constructors are mapped to "Left", "Right".++  * Ordering's are represented by their constructor names (was+    funky int-mapping.)++  * JSON.Text.Result is now an instance of MonadError; contributed+    by Andy Gimblett.++  * Included Lennart Augustsson's contributed generic JSON encoder,+    in Text.JSON.Generic++  * Optional JSON dict-mapping for Data.Map and Data.IntMap+

@@ -1,10 +1,11 @@+{-# OPTIONS_GHC -XCPP -XMultiParamTypeClasses -XTypeSynonymInstances #-} -------------------------------------------------------------------- -- | -- Module    : Text.JSON--- Copyright : (c) Galois, Inc. 2007+-- Copyright : (c) Galois, Inc. 2007-2009 -- License   : BSD3 ----- Maintainer:  Don Stewart <dons@galois.com>+-- Maintainer:  Sigbjorn Finne <sof@galois.com> -- Stability :  provisional -- Portability: portable --@@ -43,30 +44,35 @@   , readJSArray, readJSObject, readJSValue      -- ** Writing JSON-  , showJSNull, showJSBool, showJSRational, showJSArray+  , showJSNull, showJSBool, showJSArray+  , showJSRational, showJSRational'   , showJSObject, showJSValue      -- ** Instance helpers   , makeObj, valFromObj-+     ) 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,MonadPlus(..)) import Control.Applicative+import Control.Monad.Error ( MonadError(..) )  import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.IntSet as I+import qualified Data.Set as Set import qualified Data.Map as M+import qualified Data.IntMap as IntMap +import qualified Data.Array as Array+ ------------------------------------------------------------------------  -- | Decode a String representing a JSON value @@ -150,8 +156,14 @@   Ok a >>= f    = f a   Error x >>= _ = Error x +instance MonadError String Result where+  throwError x = Error x++  catchError (Error e) h = h e+  catchError x _ = x+ -- | Convenient error generation-mkError :: (JSON a) => String -> Result a+mkError :: String -> Result a mkError s = Error s  --------------------------------------------------------------------@@ -205,114 +217,116 @@   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"+  showJSON = encJSString show+  readJSON = decJSString "Ordering" readOrd+    where+     readOrd x = +       case x of+         "LT" -> return Prelude.LT+	 "EQ" -> return Prelude.EQ+	 "GT" -> return Prelude.GT+	 _    -> mkError ("Unable to read Ordering")  -- ----------------------------------------------------------------- -- Integral types  instance JSON Integer where-  showJSON = JSRational . fromIntegral-  readJSON (JSRational i) = return $ round i+  showJSON = JSRational False . 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+  showJSON = JSRational False . 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+  showJSON = JSRational False . 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+  showJSON = JSRational False . 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+  showJSON = JSRational False . 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+  showJSON = JSRational False . 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+  showJSON = JSRational False . 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+  showJSON = JSRational False . 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+  showJSON = JSRational False . 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+  showJSON = JSRational False . 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"+  showJSON = JSRational False . 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"+  showJSON = JSRational False . 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"+  showJSON = JSRational True . 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+  readJSON (JSObject o) = case "Just" `lookup` as of       Just x -> Just <$> readJSON x-      _      -> case "nothing" `lookup` as of+      _      -> 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)]+  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+  readJSON (JSObject o) = case "Left" `lookup` as of       Just a  -> Left <$> readJSON a-      Nothing -> case "right" `lookup` as of+      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)]+  showJSON (Left a)  = JSObject $ toJSObject [("Left",  showJSON a)]+  showJSON (Right b) = JSObject $ toJSObject [("Right", showJSON b)]  -- ----------------------------------------------------------------- -- Products@@ -353,40 +367,66 @@   showJSON = showJSONs   readJSON = readJSONs +-- container types:+ instance (Ord a, JSON a, JSON b) => JSON (M.Map a b) where--- the previous version: showJSON = showJSON . M.toList-  showJSON m = JSObject $ toJSObject $ -      map (\ (x,y) -> (showJSValue (showJSON x) "", showJSON y)) (M.toList m)+#if !defined(MAP_AS_DICT)+  showJSON = encJSArray M.toList+  readJSON = decJSArray "Map" M.fromList+#else+  showJSON = encJSDict M.toList+   -- backwards compatibility..+  readJSON a@JSArray{}  = M.fromList <$> readJSON a+  readJSON o = decJSDict "Map" M.fromList o+#endif -  readJSON (JSObject o) = -     mapM rd (fromJSObject o) >>= return . M.fromList-   where-     rd (a,b) = do-       f <- decode a-       g <- readJSON b-       return (f,g)+instance (JSON a) => JSON (IntMap.IntMap a) where+#if !defined(MAP_AS_DICT)+  showJSON = encJSArray IntMap.toList+  readJSON = decJSArray "IntMap" IntMap.fromList+#else+{- alternate (dict) mapping: -}+  showJSON = encJSDict IntMap.toList+  readJSON = decJSDict "IntMap" IntMap.fromList+#endif -   -- backwards compatibility..-  readJSON a@(JSArray  _) = M.fromList <$> readJSON a-  readJSON _ = mkError "Unable to read Map"+instance (Ord a, JSON a) => JSON (Set.Set a) where+  showJSON = encJSArray Set.toList+  readJSON = decJSArray "Set" Set.fromList +instance (Array.Ix i, JSON i, JSON e) => JSON (Array.Array i e) where+  showJSON = encJSArray Array.assocs+  readJSON = decJSArray "Array" arrayFromList+ instance JSON I.IntSet where-  showJSON = showJSON . I.toList-  readJSON a@(JSArray _) = I.fromList <$> readJSON a-  readJSON _ = mkError "Unable to read IntSet"+  showJSON = encJSArray I.toList+  readJSON = decJSArray "IntSet" I.fromList +-- helper functions for array / object serializers:+arrayFromList :: (Array.Ix i) => [(i,e)] -> Array.Array i e+arrayFromList [] = Array.array undefined []+arrayFromList ls@((i,_):xs) = Array.array bnds ls+       where+        bnds = +	 foldr (\ (ix,_) (mi,ma) ->+	         let+		  mi1 = min ix mi+		  ma1 = max ix ma+		 in+		 mi1 `seq` ma1 `seq` (mi1,ma1))+	       (i,i)+	       xs+ -- ----------------------------------------------------------------- -- 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"+  showJSON = encJSString S.unpack+  readJSON = decJSString "ByteString" (return . S.pack)  instance JSON L.ByteString where-  showJSON = JSString . toJSString . L.unpack-  readJSON (JSString s) = return $ L.pack $ fromJSString s-  readJSON _ = mkError "Unable to read ByteString"+  showJSON = encJSString L.unpack+  readJSON = decJSString "Lazy.ByteString" (return . L.pack)  -- ----------------------------------------------------------------- -- Instance Helpers@@ -399,3 +439,37 @@ valFromObj k o = maybe (Error $ "valFromObj: Could not find key: " ++ show k)                        readJSON 		       (lookup k (fromJSObject o))++encJSString :: (a -> String) -> a -> JSValue+encJSString f v = JSString (toJSString (f v))++decJSString :: String -> (String -> Result a) -> JSValue -> Result a+decJSString _ f (JSString s) = f (fromJSString s)+decJSString l _ _ = mkError ("readJSON{"++l++"}: unable to parse string value")++encJSArray :: (JSON a) => (b-> [a]) -> b -> JSValue+encJSArray f v = showJSON (f v)++decJSArray :: (JSON a) => String -> ([a] -> b) -> JSValue -> Result b+decJSArray _ f a@JSArray{} = f <$> readJSON a+decJSArray l _ _ = mkError ("readJSON{"++l++"}: unable to parse array value")++#if defined(MAP_AS_DICT)+encJSDict :: (JSON a, JSON b) => (c -> [(a,b)]) -> c -> JSValue+encJSDict f v = makeObj $ +  map (\ (x,y) -> (showJSValue (showJSON x) "", showJSON y)) (f v)++decJSDict :: (JSON a, JSON b)+          => String+	  -> ([(a,b)] -> c)+	  -> JSValue+	  -> Result c+decJSDict _ f (JSObject o) = mapM rd (fromJSObject o) >>= return . f+   where+     rd (a,b) = do+       pa <- decode a+       pb <- readJSON b+       return (pa,pb)+decJSDict l _ _ = mkError ("readJSON{"++l ++ "}: unable to read dict; expected JSON object")+#endif+

@@ -0,0 +1,208 @@+{-# LANGUAGE PatternGuards #-}+--------------------------------------------------------------------+-- |+-- Module    : Text.JSON.Generic+-- Copyright : (c) Lennart Augustsson, 2008-2009+-- License   : BSD3+--+-- Maintainer:  Sigbjorn Finne <sof@galois.com>+-- Stability :  provisional+-- Portability: portable+--+-- JSON serializer and deserializer using Data.Generics.+-- The functions here handle algebraic data types and primitive types.+-- It uses the same representation as "Text.JSON" for "Prelude" types.+module Text.JSON.Generic +    ( module Text.JSON+    , Data+    , Typeable+    , toJSON+    , fromJSON+    , encodeJSON+    , decodeJSON++    , toJSON_generic+    , fromJSON_generic+    ) where++import Control.Monad.State+import Control.Monad.Identity+import Data.Maybe+import Text.JSON+import Text.JSON.String ( runGetJSON )+import Data.Generics+import Data.Word+import Data.Int++import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.IntSet as I+-- FIXME: The JSON library treats this specially, needs ext2Q+-- import qualified Data.Map as M++type T a = a -> JSValue++-- |Convert anything to a JSON value.+toJSON :: (Data a) => a -> JSValue+toJSON = toJSON_generic+         `ext1Q` jList+         -- Use the standard encoding for all base types.+         `extQ` (showJSON :: T Integer)+         `extQ` (showJSON :: T Int)+         `extQ` (showJSON :: T Word8)+         `extQ` (showJSON :: T Word16)+         `extQ` (showJSON :: T Word32)+         `extQ` (showJSON :: T Word64)+         `extQ` (showJSON :: T Int8)+         `extQ` (showJSON :: T Int16)+         `extQ` (showJSON :: T Int32)+         `extQ` (showJSON :: T Int64)+         `extQ` (showJSON :: T Double)+         `extQ` (showJSON :: T Float)+         `extQ` (showJSON :: T Char)+         `extQ` (showJSON :: T String)+         -- Bool has a special encoding.+         `extQ` (showJSON :: T Bool)+         `extQ` (showJSON :: T ())+         `extQ` (showJSON :: T Ordering)+         -- More special cases.+         `extQ` (showJSON :: T I.IntSet)+         `extQ` (showJSON :: T S.ByteString)+         `extQ` (showJSON :: T L.ByteString)+  where+        -- Lists are simply coded as arrays.+        jList vs = JSArray $ map toJSON vs+++toJSON_generic :: (Data a) => a -> JSValue+toJSON_generic = generic+  where+        -- Generic encoding of an algebraic data type.+        --   No constructor, so it must be an error value.  Code it anyway as JSNull.+        --   Elide a single constructor and just code the arguments.+        --   For multiple constructors, make an object with a field name that is the+        --   constructor (except lower case) and the data is the arguments encoded.+        generic a =+            case dataTypeRep (dataTypeOf a) of+                AlgRep []  -> JSNull+                AlgRep [c] -> encodeArgs c (gmapQ toJSON a)+                AlgRep _   -> encodeConstr (toConstr a) (gmapQ toJSON a)+                rep        -> err (dataTypeOf a) rep+           where+              err dt r = error $ "toJSON: not AlgRep " ++ show r ++ "(" ++ show dt ++ ")"+        -- Encode nullary constructor as a string.+        -- Encode non-nullary constructors as an object with the constructor+        -- name as the single field and the arguments as the value.+        -- Use an array if the are no field names, but elide singleton arrays,+        -- and use an object if there are field names.+        encodeConstr c [] = JSString $ toJSString $ constrString c+        encodeConstr c as = jsObject [(constrString c, encodeArgs c as)]++        constrString = showConstr++        encodeArgs c = encodeArgs' (constrFields c)+        encodeArgs' [] [j] = j+        encodeArgs' [] js  = JSArray js+        encodeArgs' ns js  = jsObject $ zip (map mungeField ns) js++        -- Skip leading '_' in field name so we can use keywords etc. as field names.+        mungeField ('_':cs) = cs+        mungeField cs = cs++	jsObject :: [(String, JSValue)] -> JSValue+        jsObject = JSObject . toJSObject+++type F a = Result a++-- |Convert a JSON value to anything (fails if the types do not match).+fromJSON :: (Data a) => JSValue -> Result a+fromJSON j = fromJSON_generic j+             `ext1R` jList+	     --+             `extR` (value :: F Integer)+             `extR` (value :: F Int)+             `extR` (value :: F Word8)+             `extR` (value :: F Word16)+             `extR` (value :: F Word32)+             `extR` (value :: F Word64)+             `extR` (value :: F Int8)+             `extR` (value :: F Int16)+             `extR` (value :: F Int32)+             `extR` (value :: F Int64)+             `extR` (value :: F Double)+             `extR` (value :: F Float)+             `extR` (value :: F Char)+             `extR` (value :: F String)+	     --+             `extR` (value :: F Bool)+             `extR` (value :: F ())+             `extR` (value :: F Ordering)+	     --+             `extR` (value :: F I.IntSet)+             `extR` (value :: F S.ByteString)+             `extR` (value :: F L.ByteString)+  where value :: (JSON a) => Result a+        value = readJSON j++        jList :: (Data e) => Result [e]+        jList = case j of+                JSArray js -> mapM fromJSON js+                _ -> Error $ "fromJSON: Prelude.[] bad data: " ++ show j++++fromJSON_generic :: (Data a) => JSValue -> Result a+fromJSON_generic j = generic+  where+        typ = dataTypeOf $ resType generic+        generic = case dataTypeRep typ of+                      AlgRep []  -> case j of JSNull -> return (error "Empty type"); _ -> Error $ "fromJSON: no-constr bad data"+                      AlgRep [_] -> decodeArgs (indexConstr typ 1) j+                      AlgRep _   -> do (c, j') <- getConstr typ j; decodeArgs c j'+                      rep        -> Error $ "fromJSON: " ++ show rep ++ "(" ++ show typ ++ ")"+        getConstr t (JSObject o) | [(s, j')] <- fromJSObject o = do c <- readConstr' t s; return (c, j')+        getConstr t (JSString js) = do c <- readConstr' t (fromJSString js); return (c, JSNull) -- handle nullare constructor+        getConstr _ _ = Error "fromJSON: bad constructor encoding"+        readConstr' t s = +	  maybe (Error $ "fromJSON: unknown constructor: " ++ s ++ " " ++ show t) +	        return $ readConstr t s++        decodeArgs c = decodeArgs' (numConstrArgs (resType generic) c) c (constrFields c)+        decodeArgs' 0 c  _       JSNull               = construct c []   -- nullary constructor+        decodeArgs' 1 c []       jd                   = construct c [jd] -- unary constructor+        decodeArgs' n c []       (JSArray js) | n > 1 = construct c js   -- no field names+        -- FIXME? We could allow reading an array into a constructor with field names.+        decodeArgs' _ c fs@(_:_) (JSObject o)         = selectFields (fromJSObject o) fs >>= construct c -- field names+        decodeArgs' _ c _        jd                   = Error $ "fromJSON: bad decodeArgs data " ++ show (c, jd)++        -- Build the value by stepping through the list of subparts.+        construct c = evalStateT $ fromConstrM f c+          where f :: (Data a) => StateT [JSValue] Result a+                f = do js <- get; case js of [] -> lift $ Error "construct: empty list"; j' : js' -> do put js'; lift $ fromJSON j'++        -- Select the named fields from a JSON object.  FIXME? Should this use a map?+        selectFields fjs = mapM sel+          where sel f = maybe (Error $ "fromJSON: field does not exist " ++ f) Ok $ lookup f fjs++        -- Count how many arguments a constructor has.  The value x is used to determine what type the constructor returns.+        numConstrArgs :: (Data a) => a -> Constr -> Int+        numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0+          where f = do modify (+1); return undefined++        resType :: Result a -> a+        resType _ = error "resType"++-- |Encode a value as a string.+encodeJSON :: (Data a) => a -> String+encodeJSON x = showJSValue (toJSON x) ""++-- |Decode a string as a value.+decodeJSON :: (Data a) => String -> a+decodeJSON s =+    case runGetJSON readJSValue s of+    Left msg -> error msg+    Right j ->+        case fromJSON j of+        Error msg -> error msg+        Ok x -> x

@@ -1,9 +1,9 @@ -------------------------------------------------------------------- -- | -- Module    : Text.JSON.Parsec--- Copyright : (c) Galois, Inc. 2007+-- Copyright : (c) Galois, Inc. 2007-2009 ----- Maintainer:  Don Stewart <dons@galois.com>+-- Maintainer:  Sigbjorn Finne <sof@galois.com> -- Stability :  provisional -- Portability: portable --@@ -37,7 +37,7 @@                  <|> (JSArray     <$> p_array)                  <|> (JSString    <$> p_js_string)                  <|> (JSObject    <$> p_js_object)-                 <|> (JSRational  <$> p_number)+                 <|> (JSRational False <$> p_number)                  <?> "JSON value"  p_null           :: CharParser () ()

@@ -1,10 +1,10 @@ -------------------------------------------------------------------- -- | -- Module    : Text.JSON.Pretty--- Copyright : (c) Galois, Inc. 2007+-- Copyright : (c) Galois, Inc. 2007-2009 -- License   : BSD3 ----- Maintainer:  Don Stewart <dons@galois.com>+-- Maintainer:  Sigbjorn Finne <sof@galois.com> -- Stability :  provisional -- Portability: portable --@@ -25,7 +25,7 @@ pp_value v        = case v of     JSNull       -> pp_null     JSBool x     -> pp_boolean x-    JSRational x -> pp_number x+    JSRational asf x -> pp_number asf x     JSString x   -> pp_js_string x     JSArray vs   -> pp_array vs     JSObject xs  -> pp_js_object xs@@ -37,9 +37,10 @@ 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_number        :: Bool -> Rational -> Doc+pp_number _ x | denominator x == 1 = integer (numerator x)+pp_number True x                   = float (fromRational x)+pp_number _    x                   = double (fromRational x)  pp_array         :: [JSValue] -> Doc pp_array xs       = brackets $ fsep $ punctuate comma $ map pp_value xs

@@ -1,10 +1,10 @@ -------------------------------------------------------------------- -- | -- Module    : Text.JSON.ReadP--- Copyright : (c) Galois, Inc. 2007+-- Copyright : (c) Galois, Inc. 2007-2009 -- License   : BSD3 ----- Maintainer:  Don Stewart <dons@galois.com>+-- Maintainer:  Sigbjorn Finne <sof@galois.com> -- Stability :  provisional -- Portability: portable --@@ -38,7 +38,7 @@                  <|> (JSArray     <$> p_array)                  <|> (JSString    <$> p_js_string)                  <|> (JSObject    <$> p_js_object)-                 <|> (JSRational  <$> p_number)+                 <|> (JSRational False <$> p_number)  p_null           :: ReadP () p_null            = token (string "null") >> return ()

@@ -1,10 +1,10 @@ -------------------------------------------------------------------- -- | -- Module    : Text.JSON.String--- Copyright : (c) Galois, Inc. 2007+-- Copyright : (c) Galois, Inc. 2007-2009 -- License   : BSD3 ----- Maintainer:  Don Stewart <dons@galois.com>+-- Maintainer:  Sigbjorn Finne <sof@galois.com> -- Stability :  provisional -- Portability: portable --@@ -25,8 +25,8 @@   , readJSValue, readJSTopType      -- ** Writing JSON-  , showJSNull, showJSBool, showJSRational, showJSArray-  , showJSObject+  , showJSNull, showJSBool, showJSArray+  , showJSObject, showJSRational, showJSRational'    , showJSValue, showJSTopType @@ -81,11 +81,15 @@ context :: String -> String context s = take 8 s +isNullLexeme :: String -> Bool+isNullLexeme ('n':'u':'l':'l':_) = True+isNullLexeme _ = False+ -- | Read the JSON null type readJSNull :: GetJSON JSValue readJSNull = do   xs <- getInput-  if "null" `isPrefixOf` xs+  if isNullLexeme xs          then setInput (drop 4 xs) >> return JSNull         else fail $ "Unable to parse JSON null: " ++ context xs @@ -245,8 +249,8 @@     '{' : _ -> readJSObject     't' : _ -> readJSBool     'f' : _ -> readJSBool-    xs    | "null" `isPrefixOf` xs -> readJSNull-    (x:_) | x == '-' || isDigit x  -> JSRational <$> readJSRational+    _     | isNullLexeme cs -> readJSNull+    (x:_) | x == '-' || isDigit x  -> JSRational False <$> readJSRational      xs -> fail $ "Malformed JSON: invalid token in this context " ++ context xs @@ -271,12 +275,14 @@  -- | 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+showJSValue jv =+  case jv of+    JSNull{}         -> showJSNull+    JSBool b         -> showJSBool b+    JSRational asF r -> showJSRational' asF r+    JSArray a        -> showJSArray a+    JSString s       -> showJSString s+    JSObject o       -> showJSObject o  -- | Write the JSON null type showJSNull :: ShowS@@ -295,11 +301,22 @@  -- | 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+showJSRational r = showJSRational' False r++showJSRational' :: Bool -> Rational -> ShowS+showJSRational' asFloat r + | denominator r == 1      = shows $ numerator r+ | isInfinite x || isNaN x = showJSNull+ | asFloat                 = shows xf+ | otherwise               = shows x+ where +   x :: Double+   x = realToFrac r+   +   xf :: Float+   xf = realToFrac r++  -- | Show a list in JSON format showJSArray :: [JSValue] -> ShowS

@@ -2,10 +2,10 @@ -------------------------------------------------------------------- -- | -- Module    : Text.JSON.Types--- Copyright : (c) Galois, Inc. 2007+-- Copyright : (c) Galois, Inc. 2007-2009 -- License   : BSD3 ----- Maintainer:  Don Stewart <dons@galois.com>+-- Maintainer:  Sigbjorn Finne <sof@galois.com> -- Stability :  provisional -- Portability: portable --@@ -57,7 +57,7 @@ data JSValue     = JSNull     | JSBool     !Bool-    | JSRational !Rational+    | JSRational Bool{-as Float?-} !Rational     | JSString   JSString     | JSArray    [JSValue]     | JSObject   (JSObject JSValue)@@ -74,7 +74,7 @@  -- | As can association lists newtype JSObject e = JSONObject { fromJSObject :: [(String, e)] }-    deriving (Eq, Ord, Show, Read, Typeable)+    deriving (Eq, Ord, Show, Read, Typeable )  -- | Make JSON object out of an association list. toJSObject :: [(String,a)] -> JSObject a

@@ -1,5 +1,5 @@ name:               json-version:            0.3.6+version:            0.4.1 synopsis:           Support for serialising Haskell to and from JSON description:     JSON (JavaScript Object Notation) is a lightweight data-interchange@@ -15,10 +15,12 @@ license-file:       LICENSE author:             Galois Inc. maintainer:         Sigbjorn Finne <sof@galois.com>-Copyright:          (c) 2007-2008 Galois Inc.+Copyright:          (c) 2007-2009 Galois Inc. cabal-version:      >= 1.2.0 build-type: Simple extra-source-files:+    CHANGES+    tests/GenericTest.hs     tests/HUnit.hs     tests/Makefile     tests/Parallel.hs@@ -71,7 +73,14 @@ flag pretty   default: True   description: Add support for using pretty printing combinators.+flag generic+  default: True+  description: Add support for generic encoder. +flag mapdict+  default: False+  description: Encode Haskell maps as JSON dicts+ library   exposed-modules: Text.JSON,                    Text.JSON.Types,@@ -80,7 +89,10 @@   ghc-options:     -Wall -O2    if flag(split-base)-    build-depends:   base >= 3, array, containers, bytestring+    build-depends:   base >= 3, array, containers, bytestring, mtl+    if flag(generic)+      build-depends:    mtl, syb+      exposed-modules:  Text.JSON.Generic     if flag(parsec)       build-depends:    parsec       exposed-modules:  Text.JSON.Parsec@@ -89,3 +101,6 @@       exposed-modules:  Text.JSON.Pretty   else     build-depends:    base < 3++  if flag(mapdict)+     cpp-options:     -DMAP_AS_DICT

@@ -0,0 +1,81 @@+{-# LANGUAGE DeriveDataTypeable, ExtendedDefaultRules, EmptyDataDecls #-}+module Main where+import Text.JSON.Generic+import Data.Word+import Data.Int++data Foo = Foo { a :: Int, b :: Bool, c :: Baz } | None+    deriving (Typeable, Data, Show, Eq)++data Baz = Baz Int+    deriving (Typeable, Data, Show, Eq)++data Bar = Int :+: Int | Zero+    deriving (Typeable, Data, Show, Eq)++newtype New a = New a+    deriving (Typeable, Data, Show, Eq)++newtype Apples = Apples { noApples :: Int }+    deriving (Typeable, Data, Show, Eq)++data Record = Record { x :: Int, y :: Double, z :: Float, s :: String, t :: (Bool, Int) }+    deriving (Typeable, Data, Show, Eq)++rec = Record { x = 1, y = 2, z = 3.5, s = "hello", t = (True, 0) }++data Tree a = Leaf | Node (Tree a) a (Tree a)+    deriving (Typeable, Data, Show, Eq)++atree = build 4+  where build 0 = Leaf+        build 1 = Node Leaf 100 Leaf+        build n = Node (build (n-1)) n (build (n-2))++data Color = Red | Green | Blue+    deriving (Typeable, Data, Show, Eq, Enum)++from (Ok x) = x+from (Error s) = error s++viaJSON :: (Data a) => a -> a+viaJSON = from . fromJSON . toJSON++testJSON :: (Data a, Eq a) => a -> Bool+testJSON x = --x == viaJSON x+             x == decodeJSON (encodeJSON x)++tests = and [+    testJSON (1::Integer),+    testJSON (42::Int),+    testJSON (100::Word8),+    testJSON (-1000::Int64),+    testJSON (4.2::Double),+    testJSON (4.1::Float),+    testJSON True,+    testJSON 'q',+    testJSON "Hello, World\n",+    testJSON (Nothing :: Maybe Int),+    testJSON (Just "aa"),+    testJSON [],+    testJSON [1,2,3,4],+    testJSON (Left 1 :: Either Int Bool),+    testJSON (Right True :: Either Int Bool),+    testJSON (1,True),+    testJSON (1,2,True,'a',"apa",(4.5,99)),+    testJSON $ Baz 11,+    testJSON $ Foo 1 True (Baz 42),+    testJSON None,+    testJSON $ 2 :+: 3,+    testJSON Zero,+    testJSON $ New (2 :+: 3),+    testJSON rec,+    testJSON [LT,EQ,GT],+    testJSON atree,+    testJSON (),+    testJSON $ Apples 42,+    testJSON [Red .. Blue]+    ]++main :: IO ()+main = if tests then return () else error "Generic test failed"

@@ -4,9 +4,13 @@ 	mkdir $(ODIR)  all: $(ODIR)-	ghc -cpp -O QC.hs --make -o QC -no-recomp -odir=$(ODIR) -hidir=$(ODIR)+	ghc -cpp -O QC.hs --make -o QC -no-recomp -i.. -odir=$(ODIR) -hidir=$(ODIR) 	time ./QC-	runhaskell HUnit.hs+	runhaskell -i.. HUnit.hs++generic:	$(ODIR)+	ghc -i.. --make -fforce-recomp -odir=$(ODIR) -hidir=$(ODIR) GenericTest.hs -o GenericTest+	./GenericTest  clean: 	$(RM) -r $(ODIR)