git.iko.soy/typeable/aeson
on master help sign in
Fix formatting
48cfa91Adam Bergmark
ffi/Data/Aeson/Parser/Unescape.hs+22−21
compare with master
unifiedsplit
@@ -1,27 +1,28 @@
1{-# LANGUAGE ForeignFunctionInterface #-}
1{-# LANGUAGE ForeignFunctionInterface #-}
2−{-# LANGUAGE MagicHash #-}
2+{-# LANGUAGE MagicHash #-}
3−{-# LANGUAGE UnliftedFFITypes #-}
3+{-# LANGUAGE UnliftedFFITypes #-}
4
4
5−module Data.Aeson.Parser.Unescape (
5+module Data.Aeson.Parser.Unescape
6+ (
6− unescapeText
7+ unescapeText
7−) where
8+ ) where
8
9
9−import Control.Exception (evaluate, throw, try)
10+import Control.Exception (evaluate, throw, try)
10−import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)
11+import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)
11−import Data.ByteString as B
12+import Data.ByteString as B
12−import Data.ByteString.Internal as B hiding (c2w)
13+import Data.ByteString.Internal as B hiding (c2w)
13−import qualified Data.Text.Array as A
14−import Data.Text.Encoding.Error (UnicodeException (..))
14+import Data.Text.Encoding.Error (UnicodeException (..))
15−import Data.Text.Internal (Text (..))
15+import Data.Text.Internal (Text (..))
16−import Data.Text.Internal.Private (runText)
16+import Data.Text.Internal.Private (runText)
17−import Data.Text.Unsafe (unsafeDupablePerformIO)
17+import Data.Text.Unsafe (unsafeDupablePerformIO)
18−import Data.Word (Word8)
18+import Data.Word (Word8)
19−import Foreign.C.Types (CInt (..), CSize (..))
19+import Foreign.C.Types (CInt (..), CSize (..))
20−import Foreign.ForeignPtr (withForeignPtr)
20+import Foreign.ForeignPtr (withForeignPtr)
21−import Foreign.Marshal.Utils (with)
21+import Foreign.Marshal.Utils (with)
22−import Foreign.Ptr (Ptr, plusPtr)
22+import Foreign.Ptr (Ptr, plusPtr)
23−import Foreign.Storable (peek)
23+import Foreign.Storable (peek)
24−import GHC.Base (MutableByteArray#)
24+import GHC.Base (MutableByteArray#)
25+import qualified Data.Text.Array as A
25
26
26foreign import ccall unsafe "_js_decode_string" c_js_decode
27foreign import ccall unsafe "_js_decode_string" c_js_decode
27 :: MutableByteArray# s -> Ptr CSize
28 :: MutableByteArray# s -> Ptr CSize
pure/Data/Aeson/Parser/Unescape.hs+109−108
@@ -1,48 +1,49 @@
1−module Data.Aeson.Parser.Unescape (
1+module Data.Aeson.Parser.Unescape
2+ (
2− unescapeText
3+ unescapeText
3−) where
4+ ) where
4−
5+
5−import Control.Exception (evaluate, throw, try)
6+import Control.Exception (evaluate, throw, try)
6−import Control.Monad (when)
7+import Control.Monad (when)
7−import Data.ByteString as B
8+import Data.ByteString as B
8−import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.))
9+import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.))
9−import Data.Text (Text)
10+import Data.Text (Text)
10−import qualified Data.Text.Array as A
11+import qualified Data.Text.Array as A
11−import Data.Text.Encoding.Error (UnicodeException (..))
12+import Data.Text.Encoding.Error (UnicodeException (..))
12−import Data.Text.Internal.Private (runText)
13+import Data.Text.Internal.Private (runText)
13−import Data.Text.Unsafe (unsafeDupablePerformIO)
14+import Data.Text.Unsafe (unsafeDupablePerformIO)
14−import Data.Word (Word8, Word16, Word32)
15+import Data.Word (Word8, Word16, Word32)
15−import GHC.ST (ST)
16+import GHC.ST (ST)
16
17
17-- Different UTF states.
18-- Different UTF states.
18−data Utf =
19+data Utf =
19− UtfGround
20+ UtfGround
20− | UtfTail1
21+ | UtfTail1
21− | UtfU32e0
22+ | UtfU32e0
22− | UtfTail2
23+ | UtfTail2
23− | UtfU32ed
24+ | UtfU32ed
24− | Utf843f0
25+ | Utf843f0
25− | UtfTail3
26+ | UtfTail3
26− | Utf843f4
27+ | Utf843f4
27− deriving (Eq)
28+ deriving (Eq)
28−
29+
29−data State =
30+data State =
30− StateNone
31+ StateNone
31− | StateUtf !Utf !Word32
32+ | StateUtf !Utf !Word32
32− | StateBackslash
33+ | StateBackslash
33− | StateU0
34+ | StateU0
34− | StateU1 !Word16
35+ | StateU1 !Word16
35− | StateU2 !Word16
36+ | StateU2 !Word16
36− | StateU3 !Word16
37+ | StateU3 !Word16
37− | StateS0
38+ | StateS0
38− | StateS1
39+ | StateS1
39− | StateSU0
40+ | StateSU0
40− | StateSU1 !Word16
41+ | StateSU1 !Word16
41− | StateSU2 !Word16
42+ | StateSU2 !Word16
42− | StateSU3 !Word16
43+ | StateSU3 !Word16
43− deriving (Eq)
44+ deriving (Eq)
44−
45+
45−-- References:
46+-- References:
46-- http://bjoern.hoehrmann.de/utf-8/decoder/dfa/
47-- http://bjoern.hoehrmann.de/utf-8/decoder/dfa/
47-- https://github.com/jwilm/vte/blob/master/utf8parse/src/table.rs.in
48-- https://github.com/jwilm/vte/blob/master/utf8parse/src/table.rs.in
48
49
@@ -72,70 +73,70 @@ setByte4 point word = point .|. ((fromIntegral $ word .&. 0x7) `shiftL` 18)
72
73
73decode :: Utf -> Word32 -> Word8 -> (Utf, Word32)
74decode :: Utf -> Word32 -> Word8 -> (Utf, Word32)
74decode UtfGround point word = case word of
75decode UtfGround point word = case word of
75− w | 0x00 <= w && w <= 0x7f -> (UtfGround, fromIntegral word)
76+ w | 0x00 <= w && w <= 0x7f -> (UtfGround, fromIntegral word)
76− w | 0xc2 <= w && w <= 0xdf -> (UtfTail1, setByte2Top point word)
77+ w | 0xc2 <= w && w <= 0xdf -> (UtfTail1, setByte2Top point word)
77− 0xe0 -> (UtfU32e0, setByte3Top point word)
78+ 0xe0 -> (UtfU32e0, setByte3Top point word)
78− w | 0xe1 <= w && w <= 0xec -> (UtfTail2, setByte3Top point word)
79+ w | 0xe1 <= w && w <= 0xec -> (UtfTail2, setByte3Top point word)
79− 0xed -> (UtfU32ed, setByte3Top point word)
80+ 0xed -> (UtfU32ed, setByte3Top point word)
80− w | 0xee <= w && w <= 0xef -> (UtfTail2, setByte3Top point word)
81+ w | 0xee <= w && w <= 0xef -> (UtfTail2, setByte3Top point word)
81− 0xf0 -> (Utf843f0, setByte4 point word)
82+ 0xf0 -> (Utf843f0, setByte4 point word)
82− w | 0xf1 <= w && w <= 0xf3 -> (UtfTail3, setByte4 point word)
83+ w | 0xf1 <= w && w <= 0xf3 -> (UtfTail3, setByte4 point word)
83− 0xf4 -> (Utf843f4, setByte4 point word)
84+ 0xf4 -> (Utf843f4, setByte4 point word)
84− _ -> throwDecodeError
85+ _ -> throwDecodeError
85
86
86decode UtfU32e0 point word = case word of
87decode UtfU32e0 point word = case word of
87− w | 0xa0 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word)
88+ w | 0xa0 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word)
88− _ -> throwDecodeError
89+ _ -> throwDecodeError
89
90
90−decode UtfU32ed point word = case word of
91+decode UtfU32ed point word = case word of
91− w | 0x80 <= w && w <= 0x9f -> (UtfTail1, setByte2 point word)
92+ w | 0x80 <= w && w <= 0x9f -> (UtfTail1, setByte2 point word)
92− _ -> throwDecodeError
93+ _ -> throwDecodeError
93
94
94decode Utf843f0 point word = case word of
95decode Utf843f0 point word = case word of
95− w | 0x90 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word)
96+ w | 0x90 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word)
96− _ -> throwDecodeError
97+ _ -> throwDecodeError
97
98
98decode Utf843f4 point word = case word of
99decode Utf843f4 point word = case word of
99− w | 0x80 <= w && w <= 0x8f -> (UtfTail2, setByte3 point word)
100+ w | 0x80 <= w && w <= 0x8f -> (UtfTail2, setByte3 point word)
100− _ -> throwDecodeError
101+ _ -> throwDecodeError
101
102
102decode UtfTail3 point word = case word of
103decode UtfTail3 point word = case word of
103− w | 0x80 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word)
104+ w | 0x80 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word)
104− _ -> throwDecodeError
105+ _ -> throwDecodeError
105
106
106decode UtfTail2 point word = case word of
107decode UtfTail2 point word = case word of
107− w | 0x80 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word)
108+ w | 0x80 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word)
108− _ -> throwDecodeError
109+ _ -> throwDecodeError
109
110
110decode UtfTail1 point word = case word of
111decode UtfTail1 point word = case word of
111− w | 0x80 <= w && w <= 0xbf -> (UtfGround, setByte1 point word)
112+ w | 0x80 <= w && w <= 0xbf -> (UtfGround, setByte1 point word)
112− _ -> throwDecodeError
113+ _ -> throwDecodeError
113
114
114{-# INLINE decode #-}
115{-# INLINE decode #-}
115
116
116decodeHex :: Word8 -> Word16
117decodeHex :: Word8 -> Word16
117−decodeHex 48 = 0 -- '0'
118+decodeHex 48 = 0 -- '0'
118−decodeHex 49 = 1 -- '1'
119+decodeHex 49 = 1 -- '1'
119−decodeHex 50 = 2 -- '2'
120+decodeHex 50 = 2 -- '2'
120−decodeHex 51 = 3 -- '3'
121+decodeHex 51 = 3 -- '3'
121−decodeHex 52 = 4 -- '4'
122+decodeHex 52 = 4 -- '4'
122−decodeHex 53 = 5 -- '5'
123+decodeHex 53 = 5 -- '5'
123−decodeHex 54 = 6 -- '6'
124+decodeHex 54 = 6 -- '6'
124−decodeHex 55 = 7 -- '7'
125+decodeHex 55 = 7 -- '7'
125−decodeHex 56 = 8 -- '8'
126+decodeHex 56 = 8 -- '8'
126−decodeHex 57 = 9 -- '9'
127+decodeHex 57 = 9 -- '9'
127−decodeHex 65 = 10 -- 'A'
128+decodeHex 65 = 10 -- 'A'
128−decodeHex 97 = 10 -- 'a'
129+decodeHex 97 = 10 -- 'a'
129−decodeHex 66 = 11 -- 'B'
130+decodeHex 66 = 11 -- 'B'
130−decodeHex 98 = 11 -- 'b'
131+decodeHex 98 = 11 -- 'b'
131−decodeHex 67 = 12 -- 'C'
132+decodeHex 67 = 12 -- 'C'
132−decodeHex 99 = 12 -- 'c'
133+decodeHex 99 = 12 -- 'c'
133−decodeHex 68 = 13 -- 'D'
134+decodeHex 68 = 13 -- 'D'
134−decodeHex 100 = 13 -- 'd'
135+decodeHex 100 = 13 -- 'd'
135−decodeHex 69 = 14 -- 'E'
136+decodeHex 69 = 14 -- 'E'
136−decodeHex 101 = 14 -- 'e'
137+decodeHex 101 = 14 -- 'e'
137−decodeHex 70 = 15 -- 'F'
138+decodeHex 70 = 15 -- 'F'
138−decodeHex 102 = 15 -- 'f'
139+decodeHex 102 = 15 -- 'f'
139decodeHex _ = throwDecodeError
140decodeHex _ = throwDecodeError
140{-# INLINE decodeHex #-}
141{-# INLINE decodeHex #-}
141
142
@@ -156,12 +157,12 @@ unescapeText' bs = runText $ \done -> do
156 runUtf dest pos st point c = case decode st point c of
157 runUtf dest pos st point c = case decode st point c of
157 (UtfGround, 92) -> -- Backslash
158 (UtfGround, 92) -> -- Backslash
158 return (pos, StateBackslash)
159 return (pos, StateBackslash)
159− (UtfGround, w) | w <= 0xffff ->
160+ (UtfGround, w) | w <= 0xffff ->
160 writeAndReturn dest pos (fromIntegral w) StateNone
161 writeAndReturn dest pos (fromIntegral w) StateNone
161 (UtfGround, w) -> do
162 (UtfGround, w) -> do
162 write dest pos (0xd7c0 + fromIntegral (w `shiftR` 10))
163 write dest pos (0xd7c0 + fromIntegral (w `shiftR` 10))
163 writeAndReturn dest (pos + 1) (0xdc00 + fromIntegral (w .&. 0x3ff)) StateNone
164 writeAndReturn dest (pos + 1) (0xdc00 + fromIntegral (w .&. 0x3ff)) StateNone
164− (st', p) ->
165+ (st', p) ->
165 return (pos, StateUtf st' p)
166 return (pos, StateUtf st' p)
166
167
167 {-# INLINE runUtf #-}
168 {-# INLINE runUtf #-}
@@ -189,24 +190,24 @@ unescapeText' bs = runText $ \done -> do
189 f _ ( _, StateBackslash) _ = throwDecodeError
190 f _ ( _, StateBackslash) _ = throwDecodeError
190
191
191 -- Processing '\u'.
192 -- Processing '\u'.
192− f _ (pos, StateU0) c =
193+ f _ (pos, StateU0) c =
193 let w = decodeHex c in
194 let w = decodeHex c in
194 return (pos, StateU1 (w `shiftL` 12))
195 return (pos, StateU1 (w `shiftL` 12))
195
196
196− f _ (pos, StateU1 w') c =
197+ f _ (pos, StateU1 w') c =
197 let w = decodeHex c in
198 let w = decodeHex c in
198 return (pos, StateU2 (w' .|. (w `shiftL` 8)))
199 return (pos, StateU2 (w' .|. (w `shiftL` 8)))
199
200
200− f _ (pos, StateU2 w') c =
201+ f _ (pos, StateU2 w') c =
201 let w = decodeHex c in
202 let w = decodeHex c in
202 return (pos, StateU3 (w' .|. (w `shiftL` 4)))
203 return (pos, StateU3 (w' .|. (w `shiftL` 4)))
203
204
204− f dest (pos, StateU3 w') c =
205+ f dest (pos, StateU3 w') c =
205 let w = decodeHex c in
206 let w = decodeHex c in
206 let u = w' .|. w in
207 let u = w' .|. w in
207
208
208 -- Get next state based on surrogates.
209 -- Get next state based on surrogates.
209− let st =
210+ let st =
210 if u >= 0xd800 && u <= 0xdbff then -- High surrogate.
211 if u >= 0xd800 && u <= 0xdbff then -- High surrogate.
211 StateS0
212 StateS0
212 else if u >= 0xdc00 && u <= 0xdfff then -- Low surrogate.
213 else if u >= 0xdc00 && u <= 0xdfff then -- Low surrogate.
@@ -223,19 +224,19 @@ unescapeText' bs = runText $ \done -> do
223 f _ (pos, StateS1) 117 = return (pos, StateSU0) -- u
224 f _ (pos, StateS1) 117 = return (pos, StateSU0) -- u
224 f _ ( _, StateS1) _ = throwDecodeError
225 f _ ( _, StateS1) _ = throwDecodeError
225
226
226− f _ (pos, StateSU0) c =
227+ f _ (pos, StateSU0) c =
227 let w = decodeHex c in
228 let w = decodeHex c in
228 return (pos, StateSU1 (w `shiftL` 12))
229 return (pos, StateSU1 (w `shiftL` 12))
229
230
230− f _ (pos, StateSU1 w') c =
231+ f _ (pos, StateSU1 w') c =
231 let w = decodeHex c in
232 let w = decodeHex c in
232 return (pos, StateSU2 (w' .|. (w `shiftL` 8)))
233 return (pos, StateSU2 (w' .|. (w `shiftL` 8)))
233
234
234− f _ (pos, StateSU2 w') c =
235+ f _ (pos, StateSU2 w') c =
235 let w = decodeHex c in
236 let w = decodeHex c in
236 return (pos, StateSU3 (w' .|. (w `shiftL` 4)))
237 return (pos, StateSU3 (w' .|. (w `shiftL` 4)))
237
238
238− f dest (pos, StateSU3 w') c =
239+ f dest (pos, StateSU3 w') c =
239 let w = decodeHex c in
240 let w = decodeHex c in
240 let u = w' .|. w in
241 let u = w' .|. w in
241
242
@@ -251,19 +252,19 @@ unescapeText' bs = runText $ \done -> do
251
252
252write :: A.MArray s -> Int -> Word16 -> ST s ()
253write :: A.MArray s -> Int -> Word16 -> ST s ()
253write dest pos char =
254write dest pos char =
254− A.unsafeWrite dest pos char
255+ A.unsafeWrite dest pos char
255{-# INLINE write #-}
256{-# INLINE write #-}
256
257
257writeAndReturn :: A.MArray s -> Int -> Word16 -> t -> ST s (Int, t)
258writeAndReturn :: A.MArray s -> Int -> Word16 -> t -> ST s (Int, t)
258writeAndReturn dest pos char res = do
259writeAndReturn dest pos char res = do
259− write dest pos char
260+ write dest pos char
260− return (pos + 1, res)
261+ return (pos + 1, res)
261{-# INLINE writeAndReturn #-}
262{-# INLINE writeAndReturn #-}
262−
263+
263throwDecodeError :: a
264throwDecodeError :: a
264−throwDecodeError =
265+throwDecodeError =
265− let desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" in
266+ let desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" in
266− throw (DecodeError desc Nothing)
267+ throw (DecodeError desc Nothing)
267{-# INLINE throwDecodeError #-}
268{-# INLINE throwDecodeError #-}
268
269
269unescapeText :: ByteString -> Either UnicodeException Text
270unescapeText :: ByteString -> Either UnicodeException Text