git.iko.soy/typeable/aeson
on master help sign in
Use blaze-builder to construct strings slightly more quickly.
e32125bBryan O'Sullivan
Data/Aeson/Parser.hs+31−24
compare with master
unifiedsplit
@@ -15,6 +15,9 @@ module Data.Aeson.Parser
15 , value
15 , value
16 ) where
16 ) where
17
17
18+import Blaze.ByteString.Builder (fromByteString, toByteString)
19+import Blaze.ByteString.Builder.Char.Utf8 (fromChar)
20+import Blaze.ByteString.Builder.Word (fromWord8)
18import Control.Applicative as A
21import Control.Applicative as A
19import Control.Monad (when)
22import Control.Monad (when)
20import Data.Aeson.Types (Value(..))
23import Data.Aeson.Types (Value(..))
@@ -23,8 +26,9 @@ import Data.Bits ((.|.), shiftL)
23import Data.ByteString as B
26import Data.ByteString as B
24import Data.Char (chr)
27import Data.Char (chr)
25import Data.Map as Map
28import Data.Map as Map
29+import Data.Monoid (mappend, mempty)
26import Data.Text as T
30import Data.Text as T
27−import Data.Text.Encoding (decodeUtf8, encodeUtf8)
31+import Data.Text.Encoding (decodeUtf8)
28import Data.Vector as Vector hiding ((++))
32import Data.Vector as Vector hiding ((++))
29import Data.Word (Word8)
33import Data.Word (Word8)
30import qualified Data.Attoparsec as A
34import qualified Data.Attoparsec as A
@@ -36,19 +40,24 @@ json :: Parser Value
36json = do
40json = do
37 c <- skipSpace *> anyChar
41 c <- skipSpace *> anyChar
38 case c of
42 case c of
39− '{' -> skipSpace *> object_
43+ '{' -> object_
40− '[' -> skipSpace *> array_
44+ '[' -> array_
41 _ -> fail "root value is not an object or array"
45 _ -> fail "root value is not an object or array"
42
46
43object_ :: Parser Value
47object_ :: Parser Value
44object_ = do
48object_ = do
49+ skipSpace
50+ let pair = do
45− let pair = liftA2 (,) (jstring <* skipSpace) (char8 ':' *> skipSpace *> value)
51+ a <- jstring <* skipSpace
52+ b <- char ':' *> skipSpace *> value
53+ return (a,b)
46− vals <- ((pair <* skipSpace) `sepBy` (char8 ',' *> skipSpace)) <* char8 '}'
54+ vals <- ((pair <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char '}'
47 return . Object $ Map.fromList vals
55 return . Object $ Map.fromList vals
48
56
49array_ :: Parser Value
57array_ :: Parser Value
50array_ = do
58array_ = do
59+ skipSpace
51− vals <- ((value <* skipSpace) `sepBy` (char8 ',' *> skipSpace)) <* char8 ']'
60+ vals <- ((value <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char ']'
52 return . Array $ Vector.fromList vals
61 return . Array $ Vector.fromList vals
53
62
54-- | Parse any JSON value. Use 'json' in preference to this function
63-- | Parse any JSON value. Use 'json' in preference to this function
@@ -59,16 +68,17 @@ value = most <|> (Number <$> double)
59 most = do
68 most = do
60 c <- anyChar
69 c <- anyChar
61 case c of
70 case c of
62− '{' -> skipSpace *> object_
71+ '{' -> object_
63− '[' -> skipSpace *> array_
72+ '[' -> array_
64 '"' -> String <$> jstring_
73 '"' -> String <$> jstring_
65 'f' -> string "alse" *> pure (Bool False)
74 'f' -> string "alse" *> pure (Bool False)
66 't' -> string "rue" *> pure (Bool True)
75 't' -> string "rue" *> pure (Bool True)
67 'n' -> string "ull" *> pure Null
76 'n' -> string "ull" *> pure Null
68− _ -> A.empty
77+ _ -> fail "not a valid JSON value"
69
78
70−doubleQuote :: Word8
79+doubleQuote, backslash :: Word8
71doubleQuote = 34
80doubleQuote = 34
81+backslash = 92
72
82
73jstring :: Parser Text
83jstring :: Parser Text
74jstring = A.word8 doubleQuote *> jstring_
84jstring = A.word8 doubleQuote *> jstring_
@@ -76,14 +86,13 @@ jstring = A.word8 doubleQuote *> jstring_
76-- | Parse a string without a leading quote.
86-- | Parse a string without a leading quote.
77jstring_ :: Parser Text
87jstring_ :: Parser Text
78jstring_ = do
88jstring_ = do
79− let backslash = 92
80 s <- A.scan False $ \s c -> if s then Just False
89 s <- A.scan False $ \s c -> if s then Just False
81 else if c == doubleQuote
90 else if c == doubleQuote
82 then Nothing
91 then Nothing
83 else Just (c == backslash)
92 else Just (c == backslash)
84 _ <- A.word8 doubleQuote
93 _ <- A.word8 doubleQuote
85 if backslash `B.elem` s
94 if backslash `B.elem` s
86− then (decodeUtf8 . B.concat) <$> reparse unescape s
95+ then decodeUtf8 <$> reparse unescape s
87 else return (decodeUtf8 s)
96 else return (decodeUtf8 s)
88
97
89reparse :: Parser a -> ByteString -> Parser a
98reparse :: Parser a -> ByteString -> Parser a
@@ -92,10 +101,9 @@ reparse p s = case (case parse p s of {Partial k -> k ""; r -> r}) of
92 Fail _ _ msg -> fail msg
101 Fail _ _ msg -> fail msg
93 _ -> fail "unexpected failure"
102 _ -> fail "unexpected failure"
94
103
95−unescape :: Parser [ByteString]
104+unescape :: Parser ByteString
96−unescape = Prelude.reverse <$> go [] where
105+unescape = toByteString <$> go mempty where
97 go acc = do
106 go acc = do
98− let backslash = 92
99 h <- A.takeWhile (/=backslash)
107 h <- A.takeWhile (/=backslash)
100 let rest = do
108 let rest = do
101 start <- A.take 2
109 start <- A.take 2
@@ -105,21 +113,23 @@ unescape = Prelude.reverse <$> go [] where
105 Just i -> i
113 Just i -> i
106 _ -> 255
114 _ -> 255
107 when (slash /= backslash || escape == 255) $
115 when (slash /= backslash || escape == 255) $
108− fail "bad escape sequence"
116+ fail "invalid JSON escape sequence"
117+ let continue m = go (acc `mappend` fromByteString h `mappend` m)
118+ {-# INLINE continue #-}
109 if t /= 117 -- 'u'
119 if t /= 117 -- 'u'
110− then go (B.singleton (B.unsafeIndex mapping escape):h:acc)
120+ then continue (fromWord8 (B.unsafeIndex mapping escape))
111 else do
121 else do
112 a <- hexQuad
122 a <- hexQuad
113 if a < 0xd800 || a > 0xdfff
123 if a < 0xd800 || a > 0xdfff
114− then go (encodeUtf8 (T.singleton . chr $ a):h:acc)
124+ then continue (fromChar (chr a))
115 else do
125 else do
116 b <- string "\\u" *> hexQuad
126 b <- string "\\u" *> hexQuad
117 if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff
127 if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff
118 then let !c = ((a - 0xd800) `shiftL` 10) + (b - 0xdc00) +
128 then let !c = ((a - 0xd800) `shiftL` 10) + (b - 0xdc00) +
119 0x10000
129 0x10000
120− in go (encodeUtf8 (T.singleton (chr c)):h:acc)
130+ in continue (fromChar (chr c))
121 else fail "invalid UTF-16 surrogates"
131 else fail "invalid UTF-16 surrogates"
122− rest <|> return (h:acc)
132+ rest <|> return (acc `mappend` fromByteString h)
123 mapping = "\"\\/\n\t\b\r\f"
133 mapping = "\"\\/\n\t\b\r\f"
124
134
125hexQuad :: Parser Int
135hexQuad :: Parser Int
@@ -130,10 +140,7 @@ hexQuad = do
130 | w >= 65 && w <= 90 = w - 55
140 | w >= 65 && w <= 90 = w - 55
131 | otherwise = 255
141 | otherwise = 255
132 where w = fromIntegral $ B.unsafeIndex s n
142 where w = fromIntegral $ B.unsafeIndex s n
133− a = hex 0
143+ a = hex 0; b = hex 1; c = hex 2; d = hex 3
134− b = hex 1
135− c = hex 2
136− d = hex 3
137 if (a .|. b .|. c .|. d) /= 255
144 if (a .|. b .|. c .|. d) /= 255
138 then return $! d .|. (c `shiftL` 4) .|. (b `shiftL` 8) .|. (a `shiftL` 12)
145 then return $! d .|. (c `shiftL` 4) .|. (b `shiftL` 8) .|. (a `shiftL` 12)
139 else fail "invalid hex escape"
146 else fail "invalid hex escape"