@@ -1,48 +1,49 @@
1−module Data.Aeson.Parser.Unescape (
2− unescapeText
3−) where
4−
5−import Control.Exception (evaluate, throw, try)
6−import Control.Monad (when)
7−import Data.ByteString as B
8−import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.))
9−import Data.Text (Text)
10−import qualified Data.Text.Array as A
11−import Data.Text.Encoding.Error (UnicodeException (..))
12−import Data.Text.Internal.Private (runText)
13−import Data.Text.Unsafe (unsafeDupablePerformIO)
14−import Data.Word (Word8, Word16, Word32)
15−import GHC.ST (ST)
1+module Data.Aeson.Parser.Unescape
2+ (
3+ unescapeText
4+ ) where
5+
6+import Control.Exception (evaluate, throw, try)
7+import Control.Monad (when)
8+import Data.ByteString as B
9+import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.))
10+import Data.Text (Text)
11+import qualified Data.Text.Array as A
12+import Data.Text.Encoding.Error (UnicodeException (..))
13+import Data.Text.Internal.Private (runText)
14+import Data.Text.Unsafe (unsafeDupablePerformIO)
15+import Data.Word (Word8, Word16, Word32)
16+import GHC.ST (ST)
1617
1718-- Different UTF states.
18−data Utf =
19− UtfGround
20− | UtfTail1
21− | UtfU32e0
22− | UtfTail2
23− | UtfU32ed
24− | Utf843f0
25− | UtfTail3
26− | Utf843f4
27− deriving (Eq)
28−
29−data State =
30− StateNone
31− | StateUtf !Utf !Word32
32− | StateBackslash
33− | StateU0
34− | StateU1 !Word16
35− | StateU2 !Word16
36− | StateU3 !Word16
37− | StateS0
38− | StateS1
39− | StateSU0
40− | StateSU1 !Word16
41− | StateSU2 !Word16
42− | StateSU3 !Word16
43− deriving (Eq)
44−
45−-- References:
19+data Utf =
20+ UtfGround
21+ | UtfTail1
22+ | UtfU32e0
23+ | UtfTail2
24+ | UtfU32ed
25+ | Utf843f0
26+ | UtfTail3
27+ | Utf843f4
28+ deriving (Eq)
29+
30+data State =
31+ StateNone
32+ | StateUtf !Utf !Word32
33+ | StateBackslash
34+ | StateU0
35+ | StateU1 !Word16
36+ | StateU2 !Word16
37+ | StateU3 !Word16
38+ | StateS0
39+ | StateS1
40+ | StateSU0
41+ | StateSU1 !Word16
42+ | StateSU2 !Word16
43+ | StateSU3 !Word16
44+ deriving (Eq)
45+
46+-- References:
4647-- http://bjoern.hoehrmann.de/utf-8/decoder/dfa/
4748-- https://github.com/jwilm/vte/blob/master/utf8parse/src/table.rs.in
4849
@@ -72,70 +73,70 @@ setByte4 point word = point .|. ((fromIntegral $ word .&. 0x7) `shiftL` 18)
7273
7374decode :: Utf -> Word32 -> Word8 -> (Utf, Word32)
7475decode UtfGround point word = case word of
75− w | 0x00 <= w && w <= 0x7f -> (UtfGround, fromIntegral word)
76− w | 0xc2 <= w && w <= 0xdf -> (UtfTail1, setByte2Top point word)
77− 0xe0 -> (UtfU32e0, setByte3Top point word)
78− w | 0xe1 <= w && w <= 0xec -> (UtfTail2, setByte3Top point word)
79− 0xed -> (UtfU32ed, setByte3Top point word)
80− w | 0xee <= w && w <= 0xef -> (UtfTail2, setByte3Top point word)
81− 0xf0 -> (Utf843f0, setByte4 point word)
82− w | 0xf1 <= w && w <= 0xf3 -> (UtfTail3, setByte4 point word)
83− 0xf4 -> (Utf843f4, setByte4 point word)
84− _ -> throwDecodeError
76+ w | 0x00 <= w && w <= 0x7f -> (UtfGround, fromIntegral word)
77+ w | 0xc2 <= w && w <= 0xdf -> (UtfTail1, setByte2Top point word)
78+ 0xe0 -> (UtfU32e0, setByte3Top point word)
79+ w | 0xe1 <= w && w <= 0xec -> (UtfTail2, setByte3Top point word)
80+ 0xed -> (UtfU32ed, setByte3Top point word)
81+ w | 0xee <= w && w <= 0xef -> (UtfTail2, setByte3Top point word)
82+ 0xf0 -> (Utf843f0, setByte4 point word)
83+ w | 0xf1 <= w && w <= 0xf3 -> (UtfTail3, setByte4 point word)
84+ 0xf4 -> (Utf843f4, setByte4 point word)
85+ _ -> throwDecodeError
8586
8687decode UtfU32e0 point word = case word of
87− w | 0xa0 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word)
88− _ -> throwDecodeError
88+ w | 0xa0 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word)
89+ _ -> throwDecodeError
8990
90−decode UtfU32ed point word = case word of
91− w | 0x80 <= w && w <= 0x9f -> (UtfTail1, setByte2 point word)
92− _ -> throwDecodeError
91+decode UtfU32ed point word = case word of
92+ w | 0x80 <= w && w <= 0x9f -> (UtfTail1, setByte2 point word)
93+ _ -> throwDecodeError
9394
9495decode Utf843f0 point word = case word of
95− w | 0x90 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word)
96− _ -> throwDecodeError
96+ w | 0x90 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word)
97+ _ -> throwDecodeError
9798
9899decode Utf843f4 point word = case word of
99− w | 0x80 <= w && w <= 0x8f -> (UtfTail2, setByte3 point word)
100− _ -> throwDecodeError
100+ w | 0x80 <= w && w <= 0x8f -> (UtfTail2, setByte3 point word)
101+ _ -> throwDecodeError
101102
102103decode UtfTail3 point word = case word of
103− w | 0x80 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word)
104− _ -> throwDecodeError
104+ w | 0x80 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word)
105+ _ -> throwDecodeError
105106
106107decode UtfTail2 point word = case word of
107− w | 0x80 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word)
108− _ -> throwDecodeError
108+ w | 0x80 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word)
109+ _ -> throwDecodeError
109110
110111decode UtfTail1 point word = case word of
111− w | 0x80 <= w && w <= 0xbf -> (UtfGround, setByte1 point word)
112− _ -> throwDecodeError
112+ w | 0x80 <= w && w <= 0xbf -> (UtfGround, setByte1 point word)
113+ _ -> throwDecodeError
113114
114115{-# INLINE decode #-}
115116
116117decodeHex :: Word8 -> Word16
117−decodeHex 48 = 0 -- '0'
118−decodeHex 49 = 1 -- '1'
119−decodeHex 50 = 2 -- '2'
120−decodeHex 51 = 3 -- '3'
121−decodeHex 52 = 4 -- '4'
122−decodeHex 53 = 5 -- '5'
123−decodeHex 54 = 6 -- '6'
124−decodeHex 55 = 7 -- '7'
125−decodeHex 56 = 8 -- '8'
126−decodeHex 57 = 9 -- '9'
127−decodeHex 65 = 10 -- 'A'
128−decodeHex 97 = 10 -- 'a'
129−decodeHex 66 = 11 -- 'B'
130−decodeHex 98 = 11 -- 'b'
131−decodeHex 67 = 12 -- 'C'
132−decodeHex 99 = 12 -- 'c'
133−decodeHex 68 = 13 -- 'D'
134−decodeHex 100 = 13 -- 'd'
135−decodeHex 69 = 14 -- 'E'
136−decodeHex 101 = 14 -- 'e'
137−decodeHex 70 = 15 -- 'F'
138−decodeHex 102 = 15 -- 'f'
118+decodeHex 48 = 0 -- '0'
119+decodeHex 49 = 1 -- '1'
120+decodeHex 50 = 2 -- '2'
121+decodeHex 51 = 3 -- '3'
122+decodeHex 52 = 4 -- '4'
123+decodeHex 53 = 5 -- '5'
124+decodeHex 54 = 6 -- '6'
125+decodeHex 55 = 7 -- '7'
126+decodeHex 56 = 8 -- '8'
127+decodeHex 57 = 9 -- '9'
128+decodeHex 65 = 10 -- 'A'
129+decodeHex 97 = 10 -- 'a'
130+decodeHex 66 = 11 -- 'B'
131+decodeHex 98 = 11 -- 'b'
132+decodeHex 67 = 12 -- 'C'
133+decodeHex 99 = 12 -- 'c'
134+decodeHex 68 = 13 -- 'D'
135+decodeHex 100 = 13 -- 'd'
136+decodeHex 69 = 14 -- 'E'
137+decodeHex 101 = 14 -- 'e'
138+decodeHex 70 = 15 -- 'F'
139+decodeHex 102 = 15 -- 'f'
139140decodeHex _ = throwDecodeError
140141{-# INLINE decodeHex #-}
141142
@@ -156,12 +157,12 @@ unescapeText' bs = runText $ \done -> do
156157 runUtf dest pos st point c = case decode st point c of
157158 (UtfGround, 92) -> -- Backslash
158159 return (pos, StateBackslash)
159− (UtfGround, w) | w <= 0xffff ->
160+ (UtfGround, w) | w <= 0xffff ->
160161 writeAndReturn dest pos (fromIntegral w) StateNone
161162 (UtfGround, w) -> do
162163 write dest pos (0xd7c0 + fromIntegral (w `shiftR` 10))
163164 writeAndReturn dest (pos + 1) (0xdc00 + fromIntegral (w .&. 0x3ff)) StateNone
164− (st', p) ->
165+ (st', p) ->
165166 return (pos, StateUtf st' p)
166167
167168 {-# INLINE runUtf #-}
@@ -189,24 +190,24 @@ unescapeText' bs = runText $ \done -> do
189190 f _ ( _, StateBackslash) _ = throwDecodeError
190191
191192 -- Processing '\u'.
192− f _ (pos, StateU0) c =
193+ f _ (pos, StateU0) c =
193194 let w = decodeHex c in
194195 return (pos, StateU1 (w `shiftL` 12))
195196
196− f _ (pos, StateU1 w') c =
197+ f _ (pos, StateU1 w') c =
197198 let w = decodeHex c in
198199 return (pos, StateU2 (w' .|. (w `shiftL` 8)))
199200
200− f _ (pos, StateU2 w') c =
201+ f _ (pos, StateU2 w') c =
201202 let w = decodeHex c in
202203 return (pos, StateU3 (w' .|. (w `shiftL` 4)))
203204
204− f dest (pos, StateU3 w') c =
205+ f dest (pos, StateU3 w') c =
205206 let w = decodeHex c in
206207 let u = w' .|. w in
207208
208209 -- Get next state based on surrogates.
209− let st =
210+ let st =
210211 if u >= 0xd800 && u <= 0xdbff then -- High surrogate.
211212 StateS0
212213 else if u >= 0xdc00 && u <= 0xdfff then -- Low surrogate.
@@ -223,19 +224,19 @@ unescapeText' bs = runText $ \done -> do
223224 f _ (pos, StateS1) 117 = return (pos, StateSU0) -- u
224225 f _ ( _, StateS1) _ = throwDecodeError
225226
226− f _ (pos, StateSU0) c =
227+ f _ (pos, StateSU0) c =
227228 let w = decodeHex c in
228229 return (pos, StateSU1 (w `shiftL` 12))
229230
230− f _ (pos, StateSU1 w') c =
231+ f _ (pos, StateSU1 w') c =
231232 let w = decodeHex c in
232233 return (pos, StateSU2 (w' .|. (w `shiftL` 8)))
233234
234− f _ (pos, StateSU2 w') c =
235+ f _ (pos, StateSU2 w') c =
235236 let w = decodeHex c in
236237 return (pos, StateSU3 (w' .|. (w `shiftL` 4)))
237238
238− f dest (pos, StateSU3 w') c =
239+ f dest (pos, StateSU3 w') c =
239240 let w = decodeHex c in
240241 let u = w' .|. w in
241242
@@ -251,19 +252,19 @@ unescapeText' bs = runText $ \done -> do
251252
252253write :: A.MArray s -> Int -> Word16 -> ST s ()
253254write dest pos char =
254− A.unsafeWrite dest pos char
255+ A.unsafeWrite dest pos char
255256{-# INLINE write #-}
256257
257258writeAndReturn :: A.MArray s -> Int -> Word16 -> t -> ST s (Int, t)
258259writeAndReturn dest pos char res = do
259− write dest pos char
260− return (pos + 1, res)
260+ write dest pos char
261+ return (pos + 1, res)
261262{-# INLINE writeAndReturn #-}
262−
263+
263264throwDecodeError :: a
264−throwDecodeError =
265− let desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" in
266− throw (DecodeError desc Nothing)
265+throwDecodeError =
266+ let desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" in
267+ throw (DecodeError desc Nothing)
267268{-# INLINE throwDecodeError #-}
268269
269270unescapeText :: ByteString -> Either UnicodeException Text