@@ -1,21 +1,28 @@
1+{-# LANGUAGE CPP #-}
2+
3+#ifdef CFFI
14{-# LANGUAGE ForeignFunctionInterface #-}
25{-# LANGUAGE MagicHash #-}
36{-# LANGUAGE UnliftedFFITypes #-}
7+#endif
48
59module Data.Aeson.Parser.Unescape (
610 unescapeText
711) where
812
13+#ifndef CFFI
14+
915import Control.Exception (evaluate, throw, try)
1016import Control.Monad (when)
1117import Data.ByteString as B
12−import Data.Bits (shiftL, shiftR, (.&.), (.|.))
18+import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.))
1319import Data.Text (Text)
1420import qualified Data.Text.Array as A
1521import Data.Text.Encoding.Error (UnicodeException (..))
1622import Data.Text.Internal.Private (runText)
1723import Data.Text.Unsafe (unsafeDupablePerformIO)
1824import Data.Word (Word8, Word16, Word32)
25+import GHC.ST (ST)
1926
2027-- Different UTF states.
2128data Utf =
@@ -48,16 +55,28 @@ data State =
4855-- References:
4956-- http://bjoern.hoehrmann.de/utf-8/decoder/dfa/
5057-- https://github.com/jwilm/vte/blob/master/utf8parse/src/table.rs.in
58+
59+setByte1 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a
5160setByte1 point word = point .|. fromIntegral (word .&. 0x3f)
5261{-# INLINE setByte1 #-}
62+
63+setByte2 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a
5364setByte2 point word = point .|. ((fromIntegral $ word .&. 0x3f) `shiftL` 6)
5465{-# INLINE setByte2 #-}
66+
67+setByte2Top :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a
5568setByte2Top point word = point .|. ((fromIntegral $ word .&. 0x1f) `shiftL` 6)
5669{-# INLINE setByte2Top #-}
70+
71+setByte3 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a
5772setByte3 point word = point .|. ((fromIntegral $ word .&. 0x3f) `shiftL` 12)
5873{-# INLINE setByte3 #-}
74+
75+setByte3Top :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a
5976setByte3Top point word = point .|. ((fromIntegral $ word .&. 0xf) `shiftL` 12)
6077{-# INLINE setByte3Top #-}
78+
79+setByte4 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a
6180setByte4 point word = point .|. ((fromIntegral $ word .&. 0x7) `shiftL` 18)
6281{-# INLINE setByte4 #-}
6382
@@ -100,6 +119,7 @@ decode UtfTail2 point word = case word of
100119
101120decode UtfTail1 point word = case word of
102121 w | 0x80 <= w && w <= 0xbf -> (UtfGround, setByte1 point word)
122+ _ -> throwDecodeError
103123
104124{-# INLINE decode #-}
105125
@@ -144,15 +164,15 @@ unescapeText' bs = runText $ \done -> do
144164 len = B.length bs
145165
146166 runUtf dest pos st point c = case decode st point c of
147− (UtfGround, 92) -> -- \
167+ (UtfGround, 92) -> -- Backslash
148168 return (pos, StateBackslash)
149169 (UtfGround, w) | w <= 0xffff ->
150170 writeAndReturn dest pos (fromIntegral w) StateNone
151171 (UtfGround, w) -> do
152172 write dest pos (0xd7c0 + fromIntegral (w `shiftR` 10))
153173 writeAndReturn dest (pos + 1) (0xdc00 + fromIntegral (w .&. 0x3ff)) StateNone
154− (st, p) ->
155− return (pos, StateUtf st p)
174+ (st', p) ->
175+ return (pos, StateUtf st' p)
156176
157177 {-# INLINE runUtf #-}
158178
@@ -168,15 +188,15 @@ unescapeText' bs = runText $ \done -> do
168188
169189 -- In the middle of escaping a backslash.
170190 f dest (pos, StateBackslash) 34 = writeAndReturn dest pos 34 StateNone -- "
171− f dest (pos, StateBackslash) 92 = writeAndReturn dest pos 92 StateNone -- \
191+ f dest (pos, StateBackslash) 92 = writeAndReturn dest pos 92 StateNone -- Backslash
172192 f dest (pos, StateBackslash) 47 = writeAndReturn dest pos 47 StateNone -- /
173193 f dest (pos, StateBackslash) 98 = writeAndReturn dest pos 8 StateNone -- b
174194 f dest (pos, StateBackslash) 102 = writeAndReturn dest pos 12 StateNone -- f
175195 f dest (pos, StateBackslash) 110 = writeAndReturn dest pos 10 StateNone -- n
176196 f dest (pos, StateBackslash) 114 = writeAndReturn dest pos 13 StateNone -- r
177197 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
198+ f _ (pos, StateBackslash) 117 = return (pos, StateU0) -- u
199+ f _ ( _, StateBackslash) _ = throwDecodeError
180200
181201 -- Processing '\u'.
182202 f _ (pos, StateU0) c =
@@ -207,7 +227,7 @@ unescapeText' bs = runText $ \done -> do
207227 writeAndReturn dest pos u st
208228
209229 -- Handle surrogates.
210− f _ (pos, StateS0) 92 = return (pos, StateS1) -- \
230+ f _ (pos, StateS0) 92 = return (pos, StateS1) -- Backslash
211231 f _ ( _, StateS0) _ = throwDecodeError
212232
213233 f _ (pos, StateS1) 117 = return (pos, StateSU0) -- u
@@ -239,10 +259,12 @@ unescapeText' bs = runText $ \done -> do
239259
240260{-# INLINE unescapeText' #-}
241261
262+write :: A.MArray s -> Int -> Word16 -> ST s ()
242263write dest pos char =
243264 A.unsafeWrite dest pos char
244265{-# INLINE write #-}
245266
267+writeAndReturn :: A.MArray s -> Int -> Word16 -> t -> ST s (Int, t)
246268writeAndReturn dest pos char res = do
247269 write dest pos char
248270 return (pos + 1, res)
@@ -255,9 +277,9 @@ throwDecodeError =
255277{-# INLINE throwDecodeError #-}
256278
257279
280+#else
281+-- FFI version.
258282
259−
260−{-
261283import Control.Exception (evaluate, throw, try)
262284import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)
263285import Data.ByteString as B
@@ -297,7 +319,8 @@ unescapeText' (PS fp off len) = runText $ \done -> do
297319 where
298320 desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"
299321{-# INLINE unescapeText' #-}
300−-}
322+
323+#endif
301324
302325unescapeText :: ByteString -> Either UnicodeException Text
303326unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText'