diff --git a/AttoJson.cabal b/AttoJson.cabal --- a/AttoJson.cabal +++ b/AttoJson.cabal @@ -1,5 +1,5 @@ Name: AttoJson -Version: 0.5.7 +Version: 0.5.8 Synopsis: Simple lightweight JSON parser, generator & manipulator based on ByteString Description: Simple Lightweight JSON parser & generator based on ByteString. diff --git a/Text/JSON/AttoJSON.hs b/Text/JSON/AttoJSON.hs --- a/Text/JSON/AttoJSON.hs +++ b/Text/JSON/AttoJSON.hs @@ -5,7 +5,7 @@ -- * Class and Data-Types for JSON Value JSValue (..), JSON(..), -- * Parsing & Printing - parseJSON, readJSON, showJSON, + parseJSON, readJSON, showJSON, showJSON', -- * Manipulating Objects lookup, getField, findWithDefault, lookupDeep, getFields, findDeepWithDefault, @@ -17,26 +17,28 @@ import Data.ByteString.Char8 ( append, ByteString, unfoldr, take, reverse , singleton, intercalate, concat + , foldl' ) import Data.Attoparsec ( Parser, maybeResult, eitherResult) import Data.Traversable (mapM) import Data.Attoparsec.Char8 ( char8, parse, string, decimal, skipSpace, satisfy , inClass, sepBy, option, many, endOfInput, try, feed + , takeWhile1, isDigit ) import Prelude hiding (concatMap, reverse, replicate, take , Show(..), concat, mapM, lookup) import qualified Prelude as P (Show, reverse, map) import Data.Foldable (foldrM) -import Data.Bits (shiftR, (.&.)) +import Data.Bits (shiftR, shiftL, (.&.), (.|.)) import Control.Arrow (second, (***)) import Data.ByteString.UTF8 (fromString, toString) import Text.Show.ByteString (show) -import Data.Ratio (denominator, numerator) +import Data.Ratio (denominator, numerator, (%)) import Numeric (readHex) import Data.Map (Map, fromList, elems, mapWithKey, toList, mapKeys, insert) import qualified Data.Map as M (lookup) import Data.Generics (Data(..), Typeable(..)) -import Control.Monad (replicateM) +import Control.Monad (replicateM, guard) import Data.Maybe (fromMaybe) fromLazy = concat . L.toChunks @@ -176,7 +178,10 @@ value :: Parser JSValue value = jsString <|> number <|> object <|> array <|> try bool <|> try jsNull --- |Parse JSON source. Returns 'JSValue' ('Right') if succeed, Returns 'Left' if faild. +-- |Parse JSON source. Returns 'JSValue' ('Right') if succeed, Returns 'Left' if failed. +-- +-- The input string should be UTF8-encoded. Unicode escapes (e.g. @\"\\u266B\"@) are encoded in UTF8 +-- by the parser, so incompatibilities will arise if you try to use AttoJSON with other encodings. parseJSON :: ByteString -> Either String JSValue parseJSON = eitherResult . flip feed "" . parse (value <* skipSpace <* endOfInput) @@ -185,11 +190,13 @@ readJSON = maybeResult . flip feed "" . parse (value <* skipSpace <* endOfInput) -- |Print 'JSValue' as JSON source (not pretty). +-- +-- The output string will be in UTF8 (provided the JSValue was constructed with UTF8 strings). showJSON :: JSValue -> ByteString showJSON (JSObject dic) = "{" `append` intercalate "," mems `append` "}" where - mems = elems $ mapWithKey (\k v -> showJSString k `append` ":" `append` showJSON v) dic -showJSON (JSString jss) = showJSString jss + mems = elems $ mapWithKey (\k v -> showJSString False k `append` ":" `append` showJSON v) dic +showJSON (JSString jss) = showJSString False jss showJSON (JSNumber jsn) | denominator jsn == 1 = fromLazy $ show $ numerator jsn | otherwise = fromLazy $ show (fromRational jsn :: Double) showJSON (JSArray jss) = "[" `append` intercalate ", " (P.map showJSON jss) `append` "]" @@ -197,9 +204,17 @@ showJSON (JSBool True) = "true" showJSON (JSBool False) = "false" -showJSString :: ByteString -> ByteString -showJSString js = "\"" `append` escape js `append` "\"" +-- |Same as 'showJSON', but escape Unicode Charactors. +showJSON' :: JSValue -> ByteString +showJSON' (JSObject dic) = "{" `append` intercalate "," mems `append` "}" where + mems = elems $ mapWithKey (\k v -> showJSString True k `append` ":" `append` showJSON v) dic +showJSON' (JSString jss) = showJSString True jss +showJSON' jsv = showJSON jsv + +showJSString :: Bool -> ByteString -> ByteString +showJSString escapeU js = "\"" `append` escape js `append` "\"" + where escape :: ByteString -> ByteString escape = concat . P.map escapeCh . toString @@ -208,12 +223,11 @@ escapeCh '"' = "\\\"" escapeCh '\b' = "\\b" escapeCh '\f' = "\\f" - escapeCh '/' = "\\/" escapeCh '\n' = "\\n" escapeCh '\r' = "\\r" escapeCh '\t' = "\\t" - escapeCh ch | mustEscape ch = escapeHex $ fromEnum ch - | otherwise = singleton ch + escapeCh ch | mustEscape ch || (escapeU && ch > '\xff') = escapeHex $ fromEnum ch + | otherwise = fromString [ch] jsNull = lexeme (JSNull <$ symbol "null") bool = lexeme $ @@ -226,10 +240,12 @@ pow <- option 1 power return $ JSNumber (sig*(fromIntegral int+float)*pow) +frac :: Parser Rational frac = do + let step (a,p) w = (a * 10 + fromIntegral (fromEnum w - 48), p * 10) + finish (a,p) = a % p char8 '.' - dgs <- fromIntegral <$> decimal - return (dgs / (10^^ceiling(logBase 10 (fromRational dgs))) ) + finish . foldl' step (0,1) <$> takeWhile1 isDigit power = do string "E" <|> string "e" @@ -247,7 +263,7 @@ jsString = lexeme ( string "\"" *> (JSString . concat <$> many jsChar) <* string "\"") jsChar :: Parser ByteString jsChar = singleton <$> satisfy (\a -> not (isControlChar a || isNotHadaka a)) - <|> string "\\" *> (escapeChar <|> hex4digit) + <|> string "\\" *> (escapeChar <|> escapeUnicode) escapeChar :: Parser ByteString escapeChar = string "\"" @@ -259,11 +275,23 @@ <|> "\r" <$ char8 'r' <|> "\t" <$ char8 't' -hex4digit :: Parser ByteString +-- Parse either a single hex digit, or (if present) a surrogate pair. +escapeUnicode :: Parser ByteString +escapeUnicode = (\x -> fromString [toEnum x]) <$> do + uc <- hex4digit + if uc >= 0xd800 && uc <= 0xdbff + then try $ do + lc <- string "\\" *> hex4digit + guard (lc >= 0xdc00 && uc < 0xdfff) + return $ fromSurrogatePair (uc,lc) + <|> return uc + else return uc + +hex4digit :: Parser Int hex4digit = do string "u" ((hex, _):_) <- readHex <$> replicateM 4 (satisfy $ inClass "0-9a-zA-Z") - return $ fromString [toEnum hex] + return hex object = lexeme ( symbol "{" *> (JSObject . fromList <$> (objMember `sepBy` symbol ",")) <* symbol "}") @@ -274,7 +302,7 @@ unfoldrStep p f g a | p a = Nothing | otherwise = Just (f a, g a) -mustEscape ch = ch < ' ' || ch == '\x7f' || ch > '\xff' +mustEscape ch = ch < ' ' || ch == '\x7f' escapeHex :: Int -> ByteString escapeHex c | c < 0x10000 = show4Hex c @@ -284,10 +312,18 @@ show4Hex = ("\\u" `append`) . reverse . take 4 . (`append` "0000") . unfoldr (unfoldrStep (==0) (toHexChar .(`mod` 16)) (`div` 16)) astral :: Int -> ByteString -astral n = show4Hex (a + 0xd800) `append` show4Hex (b + 0xdc00) - where - a = (n `shiftR` 10) .&. 0x3ff - b = n .&. 0x3ff +astral n = show4Hex a `append` show4Hex b + where (a,b) = toSurrogatePair n + +fromSurrogatePair :: (Int,Int) -> Int +fromSurrogatePair (uc,lc) = 0x10000 .|. a .|. b where + a = (uc .&. 0x3ff) `shiftL` 10 + b = lc .&. 0x3ff + +toSurrogatePair :: Int -> (Int,Int) +toSurrogatePair n = (a + 0xd800, b + 0xdc00) where + a = (n `shiftR` 10) .&. 0x3ff + b = n .&. 0x3ff toHexChar :: Int -> Char toHexChar d | 0 <= d && d <= 9 = toEnum $ 48 + d