diff --git a/Text/JSON.hs b/Text/JSON.hs --- a/Text/JSON.hs +++ b/Text/JSON.hs @@ -46,6 +46,8 @@ , showJSNull, showJSBool, showJSRational, showJSArray , showJSObject, showJSValue + -- ** Instance helpers + , makeObj, valFromObj ) where @@ -57,7 +59,7 @@ import Data.Int import Data.Word import Data.Either -import Control.Monad(liftM,ap) +import Control.Monad(liftM,ap,MonadPlus(..)) import Control.Applicative import qualified Data.ByteString.Char8 as S @@ -133,11 +135,15 @@ pure = return instance Alternative Result where - Ok a <|> _ = Ok a - _ <|> Ok b = Ok b - err <|> _ = err + Ok a <|> _ = Ok a + Error _ <|> b = b empty = Error "empty" +instance MonadPlus Result where + Ok a `mplus` _ = Ok a + _ `mplus` x = x + mzero = Error "Result: MonadPlus.empty" + instance Monad Result where return x = Ok x fail x = Error x @@ -348,8 +354,20 @@ 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 +-- the previous version: showJSON = showJSON . M.toList + showJSON m = JSObject $ toJSObject $ + map (\ (x,y) -> (showJSValue (showJSON x) "", showJSON y)) (M.toList m) + + readJSON (JSObject o) = + mapM rd (fromJSObject o) >>= return . M.fromList + where + rd (a,b) = do + f <- decode a + g <- readJSON b + return (f,g) + + -- backwards compatibility.. + readJSON a@(JSArray _) = M.fromList <$> readJSON a readJSON _ = mkError "Unable to read Map" instance JSON I.IntSet where @@ -369,3 +387,15 @@ showJSON = JSString . toJSString . L.unpack readJSON (JSString s) = return $ L.pack $ fromJSString s readJSON _ = mkError "Unable to read ByteString" + +-- ----------------------------------------------------------------- +-- Instance Helpers + +makeObj :: [(String, JSValue)] -> JSValue +makeObj = JSObject . toJSObject + +-- | Pull a value out of a JSON object. +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)) diff --git a/Text/JSON/Pretty.hs b/Text/JSON/Pretty.hs --- a/Text/JSON/Pretty.hs +++ b/Text/JSON/Pretty.hs @@ -48,7 +48,7 @@ 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 | isControl c || fromEnum c >= 0x7f = uni_esc c pp_char c = char c uni_esc c = text "\\u" <> text (pad 4 (showHex (fromEnum c) "")) diff --git a/Text/JSON/String.hs b/Text/JSON/String.hs --- a/Text/JSON/String.hs +++ b/Text/JSON/String.hs @@ -32,14 +32,15 @@ ) where -import Text.JSON.Types +import Text.JSON.Types (JSValue(..), + JSString, toJSString, fromJSString, + JSObject, toJSObject, fromJSObject) -import Data.Char -import Data.List -import Data.Ratio -import Data.Either -import Control.Monad(liftM) -import Numeric +import Control.Monad (liftM) +import Data.Char (isSpace, isDigit) +import Data.List (isPrefixOf) +import Data.Ratio (numerator, denominator, (%)) +import Numeric (readHex, readDec, showHex) -- ----------------------------------------------------------------- @@ -288,24 +289,9 @@ -- | Write the JSON String type showJSString :: JSString -> ShowS -showJSString x = quote . foldr (.) quote (map sh (fromJSString x)) +showJSString x xs = quote (encJSString x (quote xs)) 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 @@ -325,14 +311,42 @@ -- | 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 [] +showAssocs start end sep xs rest = start : go xs + where + go [(k,v)] = '"' : encJSString (toJSString k) + ('"' : ':' : showJSValue v (go [])) + go ((k,v):kvs) = '"' : encJSString (toJSString k) + ('"' : ':' : showJSValue v (sep : go kvs)) + go [] = end : rest -- | 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 +showSequence start end sep xs rest = start : go xs + where + go [y] = showJSValue y (go []) + go (y:ys) = showJSValue y (sep : go ys) + go [] = end : rest + +encJSString :: JSString -> ShowS +encJSString jss ss = go (fromJSString jss) + where + go s1 = + case s1 of + (x :xs) | x < '\x20' -> '\\' : encControl x (go xs) + ('"' :xs) -> '\\' : '"' : go xs + ('\\':xs) -> '\\' : '\\' : go xs + (x :xs) -> x : go xs + "" -> ss + + encControl x xs = case x of + '\b' -> 'b' : xs + '\f' -> 'f' : xs + '\n' -> 'n' : xs + '\r' -> 'r' : xs + '\t' -> 't' : xs + _ | x < '\x10' -> 'u' : '0' : '0' : '0' : hexxs + | x < '\x100' -> 'u' : '0' : '0' : hexxs + | x < '\x1000' -> 'u' : '0' : hexxs + | otherwise -> 'u' : hexxs + where hexxs = showHex (fromEnum x) xs diff --git a/Text/JSON/Types.hs b/Text/JSON/Types.hs --- a/Text/JSON/Types.hs +++ b/Text/JSON/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} -------------------------------------------------------------------- -- | -- Module : Text.JSON.Types @@ -19,18 +20,18 @@ JSValue(..) -- * Wrapper Types - , JSString(..) + , JSString({-fromJSString-}..) , toJSString - , fromJSString - , JSObject(..) + , JSObject({-fromJSObject-}..) , toJSObject - , fromJSObject + , get_field + , set_field + ) where -import Data.Char -import Data.Ratio +import Data.Typeable ( Typeable ) -- -- | JSON values @@ -60,22 +61,29 @@ | JSString JSString | JSArray [JSValue] | JSObject (JSObject JSValue) - deriving (Show, Read, Eq, Ord) + deriving (Show, Read, Eq, Ord, Typeable) -- | Strings can be represented a little more efficiently in JSON newtype JSString = JSONString { fromJSString :: String } - deriving (Eq, Ord, Show, Read) + deriving (Eq, Ord, Show, Read, Typeable) -- | Turn a Haskell string into a JSON string. toJSString :: String -> JSString toJSString = JSONString + -- Note: we don't encode the string yet, that's done when serializing. -- | As can association lists newtype JSObject e = JSONObject { fromJSObject :: [(String, e)] } - deriving (Eq, Ord, Show, Read) + deriving (Eq, Ord, Show, Read, Typeable) -- | Make JSON object out of an association list. toJSObject :: [(String,a)] -> JSObject a toJSObject = JSONObject +-- | Get the value of a field, if it exist. +get_field :: JSObject a -> String -> Maybe a +get_field (JSONObject xs) x = lookup x xs +-- | Set the value of a field. Previous values are overwritten. +set_field :: JSObject a -> String -> a -> JSObject a +set_field (JSONObject xs) k v = JSONObject ((k,v) : filter ((/= k).fst) xs) diff --git a/json.cabal b/json.cabal --- a/json.cabal +++ b/json.cabal @@ -1,5 +1,5 @@ name: json -version: 0.3.3 +version: 0.3.6 synopsis: Support for serialising Haskell to and from JSON description: JSON (JavaScript Object Notation) is a lightweight data-interchange @@ -14,7 +14,7 @@ license: BSD3 license-file: LICENSE author: Galois Inc. -maintainer: dons@galois.com +maintainer: Sigbjorn Finne Copyright: (c) 2007-2008 Galois Inc. cabal-version: >= 1.2.0 build-type: Simple