@@ -6,6 +6,258 @@ module Data.Aeson.Parser.Unescape (
66 unescapeText
77) where
88
9+import Control.Exception (evaluate, throw, try)
10+import Control.Monad (when)
11+import Data.ByteString as B
12+import Data.Bits (shiftL, shiftR, (.&.), (.|.))
13+import Data.Text (Text)
14+import qualified Data.Text.Array as A
15+import Data.Text.Encoding.Error (UnicodeException (..))
16+import Data.Text.Internal.Private (runText)
17+import Data.Text.Unsafe (unsafeDupablePerformIO)
18+import Data.Word (Word8, Word16, Word32)
19+
20+-- Different UTF states.
21+data Utf =
22+ UtfGround
23+ | UtfTail1
24+ | UtfU32e0
25+ | UtfTail2
26+ | UtfU32ed
27+ | Utf843f0
28+ | UtfTail3
29+ | Utf843f4
30+ deriving (Eq)
31+
32+data State =
33+ StateNone
34+ | StateUtf !Utf !Word32
35+ | StateBackslash
36+ | StateU0
37+ | StateU1 !Word16
38+ | StateU2 !Word16
39+ | StateU3 !Word16
40+ | StateS0
41+ | StateS1
42+ | StateSU0
43+ | StateSU1 !Word16
44+ | StateSU2 !Word16
45+ | StateSU3 !Word16
46+ deriving (Eq)
47+
48+-- References:
49+-- http://bjoern.hoehrmann.de/utf-8/decoder/dfa/
50+-- https://github.com/jwilm/vte/blob/master/utf8parse/src/table.rs.in
51+setByte1 point word = point .|. fromIntegral (word .&. 0x3f)
52+{-# INLINE setByte1 #-}
53+setByte2 point word = point .|. ((fromIntegral $ word .&. 0x3f) `shiftL` 6)
54+{-# INLINE setByte2 #-}
55+setByte2Top point word = point .|. ((fromIntegral $ word .&. 0x1f) `shiftL` 6)
56+{-# INLINE setByte2Top #-}
57+setByte3 point word = point .|. ((fromIntegral $ word .&. 0x3f) `shiftL` 12)
58+{-# INLINE setByte3 #-}
59+setByte3Top point word = point .|. ((fromIntegral $ word .&. 0xf) `shiftL` 12)
60+{-# INLINE setByte3Top #-}
61+setByte4 point word = point .|. ((fromIntegral $ word .&. 0x7) `shiftL` 18)
62+{-# INLINE setByte4 #-}
63+
64+decode :: Utf -> Word32 -> Word8 -> (Utf, Word32)
65+decode UtfGround point word = case word of
66+ w | 0x00 <= w && w <= 0x7f -> (UtfGround, fromIntegral word)
67+ w | 0xc2 <= w && w <= 0xdf -> (UtfTail1, setByte2Top point word)
68+ 0xe0 -> (UtfU32e0, setByte3Top point word)
69+ w | 0xe1 <= w && w <= 0xec -> (UtfTail2, setByte3Top point word)
70+ 0xed -> (UtfU32ed, setByte3Top point word)
71+ w | 0xee <= w && w <= 0xef -> (UtfTail2, setByte3Top point word)
72+ 0xf0 -> (Utf843f0, setByte4 point word)
73+ w | 0xf1 <= w && w <= 0xf3 -> (UtfTail3, setByte4 point word)
74+ 0xf4 -> (Utf843f4, setByte4 point word)
75+ _ -> throwDecodeError
76+
77+decode UtfU32e0 point word = case word of
78+ w | 0xa0 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word)
79+ _ -> throwDecodeError
80+
81+decode UtfU32ed point word = case word of
82+ w | 0x80 <= w && w <= 0x9f -> (UtfTail1, setByte2 point word)
83+ _ -> throwDecodeError
84+
85+decode Utf843f0 point word = case word of
86+ w | 0x90 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word)
87+ _ -> throwDecodeError
88+
89+decode Utf843f4 point word = case word of
90+ w | 0x80 <= w && w <= 0x8f -> (UtfTail2, setByte3 point word)
91+ _ -> throwDecodeError
92+
93+decode UtfTail3 point word = case word of
94+ w | 0x80 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word)
95+ _ -> throwDecodeError
96+
97+decode UtfTail2 point word = case word of
98+ w | 0x80 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word)
99+ _ -> throwDecodeError
100+
101+decode UtfTail1 point word = case word of
102+ w | 0x80 <= w && w <= 0xbf -> (UtfGround, setByte1 point word)
103+
104+{-# INLINE decode #-}
105+
106+decodeHex :: Word8 -> Word16
107+decodeHex 48 = 0 -- '0'
108+decodeHex 49 = 1 -- '1'
109+decodeHex 50 = 2 -- '2'
110+decodeHex 51 = 3 -- '3'
111+decodeHex 52 = 4 -- '4'
112+decodeHex 53 = 5 -- '5'
113+decodeHex 54 = 6 -- '6'
114+decodeHex 55 = 7 -- '7'
115+decodeHex 56 = 8 -- '8'
116+decodeHex 57 = 9 -- '9'
117+decodeHex 65 = 10 -- 'A'
118+decodeHex 97 = 10 -- 'a'
119+decodeHex 66 = 11 -- 'B'
120+decodeHex 98 = 11 -- 'b'
121+decodeHex 67 = 12 -- 'C'
122+decodeHex 99 = 12 -- 'c'
123+decodeHex 68 = 13 -- 'D'
124+decodeHex 100 = 13 -- 'd'
125+decodeHex 69 = 14 -- 'E'
126+decodeHex 101 = 14 -- 'e'
127+decodeHex 70 = 15 -- 'F'
128+decodeHex 102 = 15 -- 'f'
129+decodeHex _ = throwDecodeError
130+{-# INLINE decodeHex #-}
131+
132+unescapeText' :: ByteString -> Text
133+unescapeText' bs = runText $ \done -> do
134+ dest <- A.new len
135+ (pos, finalState) <- B.foldl' (f' dest) (return (0, StateNone)) bs
136+
137+ -- Check final state.
138+ when ( finalState /= StateNone)
139+ throwDecodeError
140+
141+ done dest pos -- TODO: pos, pos-1??? XXX
142+
143+ where
144+ len = B.length bs
145+
146+ runUtf dest pos st point c = case decode st point c of
147+ (UtfGround, 92) -> -- \
148+ return (pos, StateBackslash)
149+ (UtfGround, w) | w <= 0xffff ->
150+ writeAndReturn dest pos (fromIntegral w) StateNone
151+ (UtfGround, w) -> do
152+ write dest pos (0xd7c0 + fromIntegral (w `shiftR` 10))
153+ writeAndReturn dest (pos + 1) (0xdc00 + fromIntegral (w .&. 0x3ff)) StateNone
154+ (st, p) ->
155+ return (pos, StateUtf st p)
156+
157+ {-# INLINE runUtf #-}
158+
159+ f' dest m c = m >>= \s -> f dest s c
160+
161+ {-# INLINE f' #-}
162+
163+ -- No pending state.
164+ f dest (pos, StateNone) c = runUtf dest pos UtfGround 0 c
165+
166+ -- In the middle of parsing a UTF string.
167+ f dest (pos, StateUtf st point) c = runUtf dest pos st point c
168+
169+ -- In the middle of escaping a backslash.
170+ f dest (pos, StateBackslash) 34 = writeAndReturn dest pos 34 StateNone -- "
171+ f dest (pos, StateBackslash) 92 = writeAndReturn dest pos 92 StateNone -- \
172+ f dest (pos, StateBackslash) 47 = writeAndReturn dest pos 47 StateNone -- /
173+ f dest (pos, StateBackslash) 98 = writeAndReturn dest pos 8 StateNone -- b
174+ f dest (pos, StateBackslash) 102 = writeAndReturn dest pos 12 StateNone -- f
175+ f dest (pos, StateBackslash) 110 = writeAndReturn dest pos 10 StateNone -- n
176+ f dest (pos, StateBackslash) 114 = writeAndReturn dest pos 13 StateNone -- r
177+ f dest (pos, StateBackslash) 116 = writeAndReturn dest pos 9 StateNone -- t
178+ f dest (pos, StateBackslash) 117 = return (pos, StateU0) -- u
179+ f dest (pos, StateBackslash) _ = throwDecodeError
180+
181+ -- Processing '\u'.
182+ f _ (pos, StateU0) c =
183+ let w = decodeHex c in
184+ return (pos, StateU1 (w `shiftL` 12))
185+
186+ f _ (pos, StateU1 w') c =
187+ let w = decodeHex c in
188+ return (pos, StateU2 (w' .|. (w `shiftL` 8)))
189+
190+ f _ (pos, StateU2 w') c =
191+ let w = decodeHex c in
192+ return (pos, StateU3 (w' .|. (w `shiftL` 4)))
193+
194+ f dest (pos, StateU3 w') c =
195+ let w = decodeHex c in
196+ let u = w' .|. w in
197+
198+ -- Get next state based on surrogates.
199+ let st =
200+ if u >= 0xd800 && u <= 0xdbff then -- High surrogate.
201+ StateS0
202+ else if u >= 0xdc00 && u <= 0xdfff then -- Low surrogate.
203+ throwDecodeError
204+ else
205+ StateNone
206+ in
207+ writeAndReturn dest pos u st
208+
209+ -- Handle surrogates.
210+ f _ (pos, StateS0) 92 = return (pos, StateS1) -- \
211+ f _ ( _, StateS0) _ = throwDecodeError
212+
213+ f _ (pos, StateS1) 117 = return (pos, StateSU0) -- u
214+ f _ ( _, StateS1) _ = throwDecodeError
215+
216+ f _ (pos, StateSU0) c =
217+ let w = decodeHex c in
218+ return (pos, StateSU1 (w `shiftL` 12))
219+
220+ f _ (pos, StateSU1 w') c =
221+ let w = decodeHex c in
222+ return (pos, StateSU2 (w' .|. (w `shiftL` 8)))
223+
224+ f _ (pos, StateSU2 w') c =
225+ let w = decodeHex c in
226+ return (pos, StateSU3 (w' .|. (w `shiftL` 4)))
227+
228+ f dest (pos, StateSU3 w') c =
229+ let w = decodeHex c in
230+ let u = w' .|. w in
231+
232+ -- Check if not low surrogate.
233+ if u < 0xdc00 || u > 0xdfff then
234+ throwDecodeError
235+ else
236+ writeAndReturn dest pos u StateNone
237+
238+ {-# INLINE f #-}
239+
240+{-# INLINE unescapeText' #-}
241+
242+write dest pos char =
243+ A.unsafeWrite dest pos char
244+{-# INLINE write #-}
245+
246+writeAndReturn dest pos char res = do
247+ write dest pos char
248+ return (pos + 1, res)
249+{-# INLINE writeAndReturn #-}
250+
251+throwDecodeError :: a
252+throwDecodeError =
253+ let desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" in
254+ throw (DecodeError desc Nothing)
255+{-# INLINE throwDecodeError #-}
256+
257+
258+
259+
260+{-
9261import Control.Exception (evaluate, throw, try)
10262import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)
11263import Data.ByteString as B
@@ -45,6 +297,7 @@ unescapeText' (PS fp off len) = runText $ \done -> do
45297 where
46298 desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"
47299{-# INLINE unescapeText' #-}
300+-}
48301
49302unescapeText :: ByteString -> Either UnicodeException Text
50303unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText'