packages feed

json 0.3.6 → 0.11

raw patch · 11 files changed

Files

+ CHANGES view
@@ -0,0 +1,51 @@+Version 0.11+  * Limit floating-point range to that of Double to avoid allocation+    overflows when constructing Rationals++Version 0.10+  * Use MonadFail, so that it works with GHC 8.8++Version 0.9.1+  * Merge-in contributions from Neil Mitchell to support GHC 7.10++Version 0.9+  * Merge-in contributions from Neil Mitchell to accomodate working with HEAD.++Version 0.8+  * Add `Applicative` instance for `GetJSON`++Version 0.4.4: released 2009-01-17; changes from 0.4.2++  * Fixes handling of unterminated strings.++Version 0.4.3: released 2009-01-17; changes from 0.4.2++  * optimize some common cases..string and int literals.+    Reduces parse times by > 2x on larger dict inputs containing+    both kinds of lits.++Version 0.4.2: released 2009-01-17; changes from 0.4.1++  * fixed Cabal build issues with various versions of 'base' and Data.Generic+  * fixed whitespace-handling bug in Parsec-based frontend.++Version 0.4.1: released 2009-01-12; changes from 0.3.6++  * 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+
Text/JSON.hs view
@@ -1,18 +1,5 @@------------------------------------------------------------------------ |--- 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.----+{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-}+-- | Serialising Haskell values to and from JSON values. module Text.JSON (     -- * JSON Types     JSValue(..)@@ -43,30 +30,35 @@   , readJSArray, readJSObject, readJSValue      -- ** Writing JSON-  , showJSNull, showJSBool, showJSRational, showJSArray+  , showJSNull, showJSBool, showJSArray+  , showJSRational, showJSRational'   , showJSObject, showJSValue      -- ** Instance helpers   , makeObj, valFromObj-+  , JSKey(..), encJSDict, decJSDict+     ) 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.Fail (MonadFail (..)) import Control.Monad(liftM,ap,MonadPlus(..)) 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.Set as Set import qualified Data.Map as M+import qualified Data.IntMap as IntMap +import qualified Data.Array as Array+import qualified Data.Text as T+ ------------------------------------------------------------------------  -- | Decode a String representing a JSON value @@ -146,12 +138,14 @@  instance Monad Result where   return x      = Ok x-  fail x        = Error x   Ok a >>= f    = f a   Error x >>= _ = Error x +instance MonadFail Result where+  fail x        = Error x+ -- | Convenient error generation-mkError :: (JSON a) => String -> Result a+mkError :: String -> Result a mkError s = Error s  --------------------------------------------------------------------@@ -205,114 +199,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,42 +349,75 @@   showJSON = showJSONs   readJSON = readJSONs +-- container types:++#if !defined(MAP_AS_DICT) 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)+  showJSON = encJSArray M.toList+  readJSON = decJSArray "Map" M.fromList -  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+  showJSON = encJSArray IntMap.toList+  readJSON = decJSArray "IntMap" IntMap.fromList -   -- backwards compatibility..-  readJSON a@(JSArray  _) = M.fromList <$> readJSON a-  readJSON _ = mkError "Unable to read Map"+#else+instance (Ord a, JSKey a, JSON b) => JSON (M.Map a b) where+  showJSON    = encJSDict . M.toList+  readJSON o  = M.fromList <$> decJSDict "Map" o +instance (JSON a) => JSON (IntMap.IntMap a) where+  {- alternate (dict) mapping: -}+  showJSON    = encJSDict . IntMap.toList+  readJSON o  = IntMap.fromList <$> decJSDict "IntMap" o+#endif+++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 step (i,i) xs++  step (ix,_) (mi,ma) =+    let mi1 = min ix mi+        ma1 = max ix ma+    in mi1 `seq` ma1 `seq` (mi1,ma1)++ -- ----------------------------------------------------------------- -- 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)  -- -----------------------------------------------------------------+-- Data.Text++instance JSON T.Text where+  readJSON (JSString s) = return (T.pack . fromJSString $ s)+  readJSON _            = mkError "Unable to read JSString"+  showJSON              = JSString . toJSString . T.unpack+++-- ----------------------------------------------------------------- -- Instance Helpers  makeObj :: [(String, JSValue)] -> JSValue@@ -398,4 +427,58 @@ valFromObj :: JSON a => String -> JSObject JSValue -> Result a valFromObj k o = maybe (Error $ "valFromObj: Could not find key: " ++ show k)                        readJSON-		       (lookup k (fromJSObject o))+                       (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")++-- | Haskell types that can be used as keys in JSON objects.+class JSKey a where+  toJSKey   :: a -> String+  fromJSKey :: String -> Maybe a++instance JSKey JSString where+  toJSKey x   = fromJSString x+  fromJSKey x = Just (toJSString x)++instance JSKey Int where+  toJSKey   = show+  fromJSKey key = case reads key of+                    [(a,"")] -> Just a+                    _        -> Nothing++-- NOTE: This prevents us from making other instances for lists but,+-- our guess is that strings are used as keys more often then other list types.+instance JSKey String where+  toJSKey   = id+  fromJSKey = Just+  +-- | Encode an association list as 'JSObject' value.+encJSDict :: (JSKey a, JSON b) => [(a,b)] -> JSValue+encJSDict v = makeObj [ (toJSKey x, showJSON y) | (x,y) <- v ]++-- | Decode a 'JSObject' value into an association list.+decJSDict :: (JSKey a, JSON b)+          => String+          -> JSValue+          -> Result [(a,b)]+decJSDict l (JSObject o) = mapM rd (fromJSObject o)+  where rd (a,b) = case fromJSKey a of+                     Just pa -> readJSON b >>= \pb -> return (pa,pb)+                     Nothing -> mkError ("readJSON{" ++ l ++ "}:" +++                                    "unable to read dict; invalid object key")++decJSDict l _ = mkError ("readJSON{"++l ++ "}: unable to read dict; expected JSON object")++
+ Text/JSON/Generic.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE PatternGuards #-}+-- | 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 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
Text/JSON/Parsec.hs view
@@ -1,13 +1,4 @@------------------------------------------------------------------------ |--- 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.+-- | Parse JSON values using the Parsec combinators.  module Text.JSON.Parsec   ( p_value@@ -19,6 +10,7 @@   , p_number   , p_js_string   , p_js_object+  , p_jvalue   , module Text.ParserCombinators.Parsec   ) where @@ -28,16 +20,19 @@ import Data.Char import Numeric +p_value :: CharParser () JSValue+p_value = spaces **> p_jvalue+ tok              :: CharParser () a -> CharParser () a-tok p             = spaces *> p+tok p             = p <** spaces -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)+p_jvalue         :: CharParser () JSValue+p_jvalue          =  (JSNull      <$$  p_null)+                 <|> (JSBool      <$$> p_boolean)+                 <|> (JSArray     <$$> p_array)+                 <|> (JSString    <$$> p_js_string)+                 <|> (JSObject    <$$> p_js_object)+                 <|> (JSRational False <$$> p_number)                  <?> "JSON value"  p_null           :: CharParser () ()@@ -45,74 +40,71 @@  p_boolean        :: CharParser () Bool p_boolean         = tok-                      (  (True  <$ string "true")-                     <|> (False <$ string "false")+                      (  (True  <$$ string "true")+                     <|> (False <$$ string "false")                       )  p_array          :: CharParser () [JSValue] p_array           = between (tok (char '[')) (tok (char ']'))-                  $ p_value `sepBy` tok (char ',')+                  $ p_jvalue `sepBy` tok (char ',')  p_string         :: CharParser () String-p_string          = between (tok (char '"')) (char '"') (many p_char)+p_string          = between (tok (char '"')) (tok (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_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 check x | code <= max_char  = return (toEnum code)+                        | otherwise         = mzero                   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+  where p_field   = (,) <$$> (p_string <** tok (char ':')) <**> p_jvalue  p_number         :: CharParser () Rational-p_number          = do s <- getInput-                       case readSigned readFloat s of-                         [(n,s1)] -> n <$ setInput s1-                         _        -> empty+p_number          = tok+                  $ do s <- getInput+                       case (reads s, readSigned readFloat s) of+                         ([(x,_)], _)+                           | isInfinite (x :: Double) -> fail "number out of range"+                         (_, [(y,s')]) -> y <$$ setInput s'+                         _ -> mzero <?> "number"  p_js_string      :: CharParser () JSString-p_js_string       = toJSString <$> p_string+p_js_string       = toJSString <$$> p_string  p_js_object      :: CharParser () (JSObject JSValue)-p_js_object       = toJSObject <$> p_object+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 -> b) -> CharParser () a -> CharParser () b+(<**>)   = ap -(<*)   :: CharParser () a -> CharParser () b -> CharParser () a-m <* n  = do x <- m; n; return x+(**>)   :: CharParser () a -> CharParser () b -> CharParser () b+(**>)    = (>>) -empty  :: CharParser () a-empty   = mzero+(<**)   :: CharParser () a -> CharParser () b -> CharParser () a+m <** n  = do x <- m; _ <- n; return x -(<$>)  :: (a -> b) -> CharParser () a -> CharParser () b-(<$>)   = fmap+(<$$>)  :: (a -> b) -> CharParser () a -> CharParser () b+(<$$>)   = fmap -(<$)   :: a -> CharParser () b -> CharParser () a-x <$ m  = m >> return x+(<$$)   :: a -> CharParser () b -> CharParser () a+x <$$ m  = m >> return x
Text/JSON/Pretty.hs view
@@ -1,14 +1,4 @@------------------------------------------------------------------------ |--- 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.+-- | Display JSON values using pretty printing combinators.  module Text.JSON.Pretty   ( module Text.JSON.Pretty@@ -17,6 +7,7 @@  import Text.JSON.Types import Text.PrettyPrint.HughesPJ+import qualified Text.PrettyPrint.HughesPJ as PP import Data.Ratio import Data.Char import Numeric@@ -25,7 +16,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 +28,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@@ -48,10 +40,10 @@ pp_string x       = doubleQuotes $ hcat $ map pp_char x   where pp_char '\\'            = text "\\\\"         pp_char '"'             = text "\\\""-        pp_char c | isControl c || fromEnum c >= 0x7f = uni_esc c+        pp_char c | isControl c = uni_esc c         pp_char c               = char c -        uni_esc c = text "\\u" <> text (pad 4 (showHex (fromEnum c) ""))+        uni_esc c = text "\\u" PP.<> text (pad 4 (showHex (fromEnum c) ""))          pad n cs  | len < n   = replicate (n-len) '0' ++ cs                   | otherwise = cs@@ -59,7 +51,7 @@  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+  where pp_field (k,v) = pp_string k PP.<> colon <+> pp_value v  pp_js_string     :: JSString -> Doc pp_js_string x    = pp_string (fromJSString x)
Text/JSON/ReadP.hs view
@@ -1,14 +1,4 @@------------------------------------------------------------------------ |--- 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.+-- | Parse JSON values using the ReadP combinators.  module Text.JSON.ReadP   ( p_value@@ -30,23 +20,23 @@ import Numeric  token            :: ReadP a -> ReadP a-token p           = skipSpaces *> p+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_value           =  (JSNull      <$$  p_null)+                 <||> (JSBool      <$$> p_boolean)+                 <||> (JSArray     <$$> p_array)+                 <||> (JSString    <$$> p_js_string)+                 <||> (JSObject    <$$> p_js_object)+                 <||> (JSRational False <$$> p_number)  p_null           :: ReadP () p_null            = token (string "null") >> return ()  p_boolean        :: ReadP Bool p_boolean         = token-                      (  (True  <$ string "true")-                     <|> (False <$ string "false")+                      (  (True  <$$ string "true")+                     <||> (False <$$ string "false")                       )  p_array          :: ReadP [JSValue]@@ -56,62 +46,66 @@ p_string         :: ReadP String p_string          = between (token (char '"')) (char '"') (many p_char)   where p_char    =  (char '\\' >> p_esc)-                 <|> (satisfy (\x -> x /= '"' && x /= '\\'))+                 <||> (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_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 check x | code <= max_char  = return (toEnum code)+                        | otherwise         = pfail                   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+  where p_field   = (,) <$$> (p_string <** token (char ':')) <**> p_value  p_number         :: ReadP Rational-p_number          = readS_to_P (readSigned readFloat)+p_number          = readS_to_P safeRationalReads +-- reading into a Double with reads is safe for huge floating-point literals+-- this will allow all floating-point literals that are small enough to fit+-- into a Double (and are thus compatible with most other json implementations)+-- to be parsed here without opening us to oversized Rational allocations+safeRationalReads :: ReadS Rational+safeRationalReads str =+  case reads str of+    [(d,_)] | not (isInfinite (d :: Double)) -> readSigned readFloat str+    _ -> []+ p_js_string      :: ReadP JSString-p_js_string       = toJSString <$> p_string+p_js_string       = toJSString <$$> p_string  p_js_object      :: ReadP (JSObject JSValue)-p_js_object       = toJSObject <$> p_object+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 -> b) -> ReadP a -> ReadP b+(<**>)   = ap -(<*)   :: ReadP a -> ReadP b -> ReadP a-m <* n  = do x <- m; n; return x+(**>)   :: ReadP a -> ReadP b -> ReadP b+(**>)    = (>>) -empty  :: ReadP a-empty   = pfail+(<**)   :: ReadP a -> ReadP b -> ReadP a+m <** n  = do x <- m; _ <- n; return x -(<|>)  :: ReadP a -> ReadP a -> ReadP a-(<|>)   = (+++)+(<||>)  :: ReadP a -> ReadP a -> ReadP a+(<||>)   = (+++) -(<$>)  :: (a -> b) -> ReadP a -> ReadP b-(<$>)   = fmap+(<$$>)  :: (a -> b) -> ReadP a -> ReadP b+(<$$>)   = fmap -(<$)   :: a -> ReadP b -> ReadP a-x <$ m  = m >> return x+(<$$)   :: a -> ReadP b -> ReadP a+x <$$ m  = m >> return x
Text/JSON/String.hs view
@@ -1,47 +1,47 @@------------------------------------------------------------------------ |--- 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+-- | Basic support for working with JSON values. -    -- ** Reading JSON-  , readJSNull, readJSBool, readJSString, readJSRational-  , readJSArray, readJSObject+module Text.JSON.String +     ( +       -- * Parsing+       --+       GetJSON+     , runGetJSON -  , readJSValue, readJSTopType+       -- ** Reading JSON+     , readJSNull+     , readJSBool+     , readJSString+     , readJSRational+     , readJSArray+     , readJSObject -    -- ** Writing JSON-  , showJSNull, showJSBool, showJSRational, showJSArray-  , showJSObject+     , readJSValue+     , readJSTopType -  , showJSValue, showJSTopType+       -- ** Writing JSON+     , showJSNull+     , showJSBool+     , showJSArray+     , showJSObject+     , showJSRational+     , showJSRational' -  ) where+     , showJSValue+     , showJSTopType+     ) where +import Prelude hiding (fail) import Text.JSON.Types (JSValue(..),                         JSString, toJSString, fromJSString,                         JSObject, toJSObject, fromJSObject) -import Control.Monad (liftM)-import Data.Char (isSpace, isDigit)-import Data.List (isPrefixOf)+import Control.Monad (liftM, ap)+import Control.Monad.Fail (MonadFail (..))+import Control.Applicative((<$>))+import qualified Control.Applicative as A+import Data.Char (isSpace, isDigit, digitToInt) import Data.Ratio (numerator, denominator, (%))-import Numeric (readHex, readDec, showHex)-+import Numeric (readHex, readDec, showHex, readSigned, readFloat)  -- ----------------------------------------------------------------- -- | Parsing JSON@@ -50,13 +50,19 @@ newtype GetJSON a = GetJSON { un :: String -> Either String (a,String) }  instance Functor GetJSON where fmap = liftM+instance A.Applicative GetJSON where+  pure  = return+  (<*>) = ap+ 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) +instance MonadFail GetJSON where+  fail x          = GetJSON (\_ -> Left x)+ -- | Run a JSON reader on an input String, returning some Haskell value. -- All input will be consumed. runGetJSON :: GetJSON a -> String -> Either String a@@ -72,9 +78,6 @@ 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@@ -85,19 +88,25 @@ 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+  case xs of+    'n':'u':'l':'l':xs1 -> setInput xs1 >> return JSNull+    _ -> fail $ "Unable to parse JSON null: " ++ context xs +tryJSNull :: GetJSON JSValue -> GetJSON JSValue+tryJSNull k = do+  xs <- getInput+  case xs of+    'n':'u':'l':'l':xs1 -> setInput xs1 >> return JSNull+    _ -> k + -- | 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-  }+  case xs of+    't':'r':'u':'e':xs1 -> setInput xs1 >> return (JSBool True)+    'f':'a':'l':'s':'e':xs1 -> setInput xs1 >> return (JSBool False)+    _ -> fail $ "Unable to parse JSON Bool: " ++ context xs  -- | Read the JSON String type readJSString :: GetJSON JSValue@@ -106,74 +115,52 @@   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+ where +  parse rs cs = +    case cs of+      '\\' : c : ds -> esc rs c ds+      '"'  : ds     -> do setInput ds+                          return (JSString (toJSString (reverse rs)))+      c    : ds+       | c >= '\x20' && c <= '\xff'    -> parse (c:rs) ds+       | c < '\x20'     -> fail $ "Illegal unescaped character in string: " ++ context cs+       | i <= 0x10ffff  -> parse (c:rs) ds+       | otherwise -> fail $ "Illegal unescaped character in string: " ++ context cs+       where+        i = (fromIntegral (fromEnum c) :: Integer)+      _ -> 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'+  esc rs c cs = case c of+   '\\' -> parse ('\\' : rs) cs+   '"'  -> parse ('"'  : rs) cs+   'n'  -> parse ('\n' : rs) cs+   'r'  -> parse ('\r' : rs) cs+   't'  -> parse ('\t' : rs) cs+   'f'  -> parse ('\f' : rs) cs+   'b'  -> parse ('\b' : rs) cs+   '/'  -> parse ('/'  : rs) cs+   'u'  -> case cs of+             d1 : d2 : d3 : d4 : cs' ->+               case readHex [d1,d2,d3,d4] of+                 [(n,"")] -> parse (toEnum n : rs) cs' -                        x -> fail $ "Unable to parse JSON String: invalid hex: " ++ context (show x)-                    _ -> fail $ "Unable to parse JSON String: invalid hex: " ++ context cs-          _ ->  fail $ "Unable to parse JSON String: invalid escape char: " ++ show c+                 x -> fail $ "Unable to parse JSON String: invalid hex: " ++ context (show x)+             _ -> fail $ "Unable to parse JSON String: invalid hex: " ++ context cs+   _ ->  fail $ "Unable to parse JSON String: invalid escape char: " ++ show c   -- | Read an Integer or Double in JSON format, returning a Rational readJSRational :: GetJSON Rational readJSRational = do   cs <- getInput-  case cs of-    '-' : ds -> negate <$> pos ds-    _        -> pos cs+  case (reads cs, readSigned readFloat cs) of+    ([(x,_)], _)+      | isInfinite (x :: Double) ->+          fail ("JSON Rational out of range: " ++ context cs)+    (_, [(y,cs')]) -> setInput cs' >> return y+    _ -> fail ("Unable to parse JSON Rational: " ++ context 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@@ -217,13 +204,13 @@    where parsePairs rs = rs `seq` do           a  <- do k  <- do x <- readJSString ; case x of-                                JSString s -> return s+                                JSString s -> return (fromJSString s)                                 _          -> fail $ "Malformed JSON field labels: object keys must be quoted strings."                    ds <- getInput                    case dropWhile isSpace ds of                        ':':es -> do setInput (dropWhile isSpace es)                                     v <- readJSValue-                                    return (fromJSString k,v)+                                    return (k,v)                        _      -> fail $ "Malformed JSON labelled field: " ++ context ds            ds <- getInput@@ -245,10 +232,9 @@     '{' : _ -> 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+    (x:_) | isDigit x || x == '-' -> JSRational False <$> readJSRational+    xs -> tryJSNull+             (fail $ "Malformed JSON: invalid token in this context " ++ context xs)  -- | Top level JSON can only be Arrays or Objects readJSTopType :: GetJSON JSValue@@ -271,12 +257,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 +283,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
Text/JSON/Types.hs view
@@ -1,18 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}------------------------------------------------------------------------ |--- 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.---+-- | Basic support for working with JSON values.  module Text.JSON.Types ( @@ -32,6 +19,7 @@   ) where  import Data.Typeable ( Typeable )+import Data.String(IsString(..))  -- -- | JSON values@@ -57,7 +45,7 @@ data JSValue     = JSNull     | JSBool     !Bool-    | JSRational !Rational+    | JSRational Bool{-as Float?-} !Rational     | JSString   JSString     | JSArray    [JSValue]     | JSObject   (JSObject JSValue)@@ -72,9 +60,15 @@ toJSString = JSONString   -- Note: we don't encode the string yet, that's done when serializing. +instance IsString JSString where+  fromString = toJSString++instance IsString JSValue where+  fromString = JSString . fromString+ -- | 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
json.cabal view
@@ -1,5 +1,6 @@+cabal-version:      2.4 name:               json-version:            0.3.6+version:            0.11 synopsis:           Support for serialising Haskell to and from JSON description:     JSON (JavaScript Object Notation) is a lightweight data-interchange@@ -11,14 +12,16 @@     This library provides a parser and pretty printer for converting     between Haskell values and JSON. category:           Web-license:            BSD3+license:            BSD-3-Clause license-file:       LICENSE author:             Galois Inc.-maintainer:         Sigbjorn Finne <sof@galois.com>-Copyright:          (c) 2007-2008 Galois Inc.-cabal-version:      >= 1.2.0+maintainer:         Iavor S. Diatchki (iavor.diatchki@gmail.com)+Copyright:          (c) 2007-2018 Galois Inc. build-type: Simple+extra-doc-files:+    CHANGES extra-source-files:+    tests/GenericTest.hs     tests/HUnit.hs     tests/Makefile     tests/Parallel.hs@@ -62,6 +65,10 @@     tests/unit/pass2.json     tests/unit/pass3.json +source-repository head+    type:     git+    location: https://github.com/GaloisInc/json.git+ flag split-base   default: True   description: Use the new split base package.@@ -71,8 +78,16 @@ 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+  default-language: Haskell2010   exposed-modules: Text.JSON,                    Text.JSON.Types,                    Text.JSON.String,@@ -80,7 +95,16 @@   ghc-options:     -Wall -O2    if flag(split-base)-    build-depends:   base >= 3, array, containers, bytestring+    if flag(generic)+      build-depends:    base >=4.9 && <5, syb >= 0.3.3++      exposed-modules:  Text.JSON.Generic+      Cpp-Options:      -DBASE_4+    else+      build-depends:    base >= 3 && <4++    build-depends:   array, containers, bytestring, mtl, text+     if flag(parsec)       build-depends:    parsec       exposed-modules:  Text.JSON.Parsec@@ -89,3 +113,9 @@       exposed-modules:  Text.JSON.Pretty   else     build-depends:    base < 3++  if flag(mapdict)+     cpp-options:     -DMAP_AS_DICT+++
+ tests/GenericTest.hs view
@@ -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"
tests/Makefile view
@@ -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)