a0a3e63 · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

have 2 versions of code one for c based version the other pure haskell

a0a3e63Marcin Tolysz10 years ago

Data/Aeson/Parser/Unescape.hs+34−11

compare with master

unifiedsplit

@@ -1,21 +1,28 @@

1+{-# LANGUAGE CPP #-}

3+#ifdef CFFI

1{-# LANGUAGE ForeignFunctionInterface #-}

4{-# LANGUAGE ForeignFunctionInterface #-}

2{-# LANGUAGE MagicHash #-}

5{-# LANGUAGE MagicHash #-}

3{-# LANGUAGE UnliftedFFITypes #-}

6{-# LANGUAGE UnliftedFFITypes #-}

7+#endif

5module Data.Aeson.Parser.Unescape (

9module Data.Aeson.Parser.Unescape (

6 unescapeText

10 unescapeText

7) where

11) where

13+#ifndef CFFI

14+

9import Control.Exception (evaluate, throw, try)

15import Control.Exception (evaluate, throw, try)

10import Control.Monad (when)

16import Control.Monad (when)

11import Data.ByteString as B

17import Data.ByteString as B

12−import Data.Bits (shiftL, shiftR, (.&.), (.|.))

18+import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.))

13import Data.Text (Text)

19import Data.Text (Text)

14import qualified Data.Text.Array as A

20import qualified Data.Text.Array as A

15import Data.Text.Encoding.Error (UnicodeException (..))

21import Data.Text.Encoding.Error (UnicodeException (..))

16import Data.Text.Internal.Private (runText)

22import Data.Text.Internal.Private (runText)

17import Data.Text.Unsafe (unsafeDupablePerformIO)

23import Data.Text.Unsafe (unsafeDupablePerformIO)

18import Data.Word (Word8, Word16, Word32)

24import Data.Word (Word8, Word16, Word32)

25+import GHC.ST (ST)

20-- Different UTF states.

27-- Different UTF states.

21data Utf =

28data Utf =

@@ -48,16 +55,28 @@ data State =

48-- References:

55-- References:

49-- http://bjoern.hoehrmann.de/utf-8/decoder/dfa/

56-- http://bjoern.hoehrmann.de/utf-8/decoder/dfa/

50-- https://github.com/jwilm/vte/blob/master/utf8parse/src/table.rs.in

57-- 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

51setByte1 point word = point .|. fromIntegral (word .&. 0x3f)

60setByte1 point word = point .|. fromIntegral (word .&. 0x3f)

52{-# INLINE setByte1 #-}

61{-# INLINE setByte1 #-}

62+

63+setByte2 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a

53setByte2 point word = point .|. ((fromIntegral $ word .&. 0x3f) `shiftL` 6)

64setByte2 point word = point .|. ((fromIntegral $ word .&. 0x3f) `shiftL` 6)

54{-# INLINE setByte2 #-}

65{-# INLINE setByte2 #-}

66+

67+setByte2Top :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a

55setByte2Top point word = point .|. ((fromIntegral $ word .&. 0x1f) `shiftL` 6)

68setByte2Top point word = point .|. ((fromIntegral $ word .&. 0x1f) `shiftL` 6)

56{-# INLINE setByte2Top #-}

69{-# INLINE setByte2Top #-}

70+

71+setByte3 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a

57setByte3 point word = point .|. ((fromIntegral $ word .&. 0x3f) `shiftL` 12)

72setByte3 point word = point .|. ((fromIntegral $ word .&. 0x3f) `shiftL` 12)

58{-# INLINE setByte3 #-}

73{-# INLINE setByte3 #-}

74+

75+setByte3Top :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a

59setByte3Top point word = point .|. ((fromIntegral $ word .&. 0xf) `shiftL` 12)

76setByte3Top point word = point .|. ((fromIntegral $ word .&. 0xf) `shiftL` 12)

60{-# INLINE setByte3Top #-}

77{-# INLINE setByte3Top #-}

78+

79+setByte4 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a

61setByte4 point word = point .|. ((fromIntegral $ word .&. 0x7) `shiftL` 18)

80setByte4 point word = point .|. ((fromIntegral $ word .&. 0x7) `shiftL` 18)

62{-# INLINE setByte4 #-}

81{-# INLINE setByte4 #-}

@@ -100,6 +119,7 @@ decode UtfTail2 point word = case word of

100

119

101decode UtfTail1 point word = case word of

120decode UtfTail1 point word = case word of

102 w | 0x80 <= w && w <= 0xbf -> (UtfGround, setByte1 point word)

121 w | 0x80 <= w && w <= 0xbf -> (UtfGround, setByte1 point word)

122+ _ -> throwDecodeError

103

123

104{-# INLINE decode #-}

124{-# INLINE decode #-}

105

125

@@ -144,15 +164,15 @@ unescapeText' bs = runText $ \done -> do

144 len = B.length bs

164 len = B.length bs

145

165

146 runUtf dest pos st point c = case decode st point c of

166 runUtf dest pos st point c = case decode st point c of

147− (UtfGround, 92) -> -- \

167+ (UtfGround, 92) -> -- Backslash

148 return (pos, StateBackslash)

168 return (pos, StateBackslash)

149 (UtfGround, w) | w <= 0xffff ->

169 (UtfGround, w) | w <= 0xffff ->

150 writeAndReturn dest pos (fromIntegral w) StateNone

170 writeAndReturn dest pos (fromIntegral w) StateNone

151 (UtfGround, w) -> do

171 (UtfGround, w) -> do

152 write dest pos (0xd7c0 + fromIntegral (w `shiftR` 10))

172 write dest pos (0xd7c0 + fromIntegral (w `shiftR` 10))

153 writeAndReturn dest (pos + 1) (0xdc00 + fromIntegral (w .&. 0x3ff)) StateNone

173 writeAndReturn dest (pos + 1) (0xdc00 + fromIntegral (w .&. 0x3ff)) StateNone

154− (st, p) ->

174+ (st', p) ->

155− return (pos, StateUtf st p)

175+ return (pos, StateUtf st' p)

156

176

157 {-# INLINE runUtf #-}

177 {-# INLINE runUtf #-}

158

178

@@ -168,15 +188,15 @@ unescapeText' bs = runText $ \done -> do

168

188

169 -- In the middle of escaping a backslash.

189 -- In the middle of escaping a backslash.

170 f dest (pos, StateBackslash) 34 = writeAndReturn dest pos 34 StateNone -- "

190 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

172 f dest (pos, StateBackslash) 47 = writeAndReturn dest pos 47 StateNone -- /

192 f dest (pos, StateBackslash) 47 = writeAndReturn dest pos 47 StateNone -- /

173 f dest (pos, StateBackslash) 98 = writeAndReturn dest pos 8 StateNone -- b

193 f dest (pos, StateBackslash) 98 = writeAndReturn dest pos 8 StateNone -- b

174 f dest (pos, StateBackslash) 102 = writeAndReturn dest pos 12 StateNone -- f

194 f dest (pos, StateBackslash) 102 = writeAndReturn dest pos 12 StateNone -- f

175 f dest (pos, StateBackslash) 110 = writeAndReturn dest pos 10 StateNone -- n

195 f dest (pos, StateBackslash) 110 = writeAndReturn dest pos 10 StateNone -- n

176 f dest (pos, StateBackslash) 114 = writeAndReturn dest pos 13 StateNone -- r

196 f dest (pos, StateBackslash) 114 = writeAndReturn dest pos 13 StateNone -- r

177 f dest (pos, StateBackslash) 116 = writeAndReturn dest pos 9 StateNone -- t

197 f dest (pos, StateBackslash) 116 = writeAndReturn dest pos 9 StateNone -- t

178− f dest (pos, StateBackslash) 117 = return (pos, StateU0) -- u

198+ f _ (pos, StateBackslash) 117 = return (pos, StateU0) -- u

179− f dest (pos, StateBackslash) _ = throwDecodeError

199+ f _ ( _, StateBackslash) _ = throwDecodeError

180

200

181 -- Processing '\u'.

201 -- Processing '\u'.

182 f _ (pos, StateU0) c =

202 f _ (pos, StateU0) c =

@@ -207,7 +227,7 @@ unescapeText' bs = runText $ \done -> do

207 writeAndReturn dest pos u st

227 writeAndReturn dest pos u st

208

228

209 -- Handle surrogates.

229 -- Handle surrogates.

210− f _ (pos, StateS0) 92 = return (pos, StateS1) -- \

230+ f _ (pos, StateS0) 92 = return (pos, StateS1) -- Backslash

211 f _ ( _, StateS0) _ = throwDecodeError

231 f _ ( _, StateS0) _ = throwDecodeError

212

232

213 f _ (pos, StateS1) 117 = return (pos, StateSU0) -- u

233 f _ (pos, StateS1) 117 = return (pos, StateSU0) -- u

@@ -239,10 +259,12 @@ unescapeText' bs = runText $ \done -> do

239

259

240{-# INLINE unescapeText' #-}

260{-# INLINE unescapeText' #-}

241

261

262+write :: A.MArray s -> Int -> Word16 -> ST s ()

242write dest pos char =

263write dest pos char =

243 A.unsafeWrite dest pos char

264 A.unsafeWrite dest pos char

244{-# INLINE write #-}

265{-# INLINE write #-}

245

266

267+writeAndReturn :: A.MArray s -> Int -> Word16 -> t -> ST s (Int, t)

246writeAndReturn dest pos char res = do

268writeAndReturn dest pos char res = do

247 write dest pos char

269 write dest pos char

248 return (pos + 1, res)

270 return (pos + 1, res)

@@ -255,9 +277,9 @@ throwDecodeError =

255{-# INLINE throwDecodeError #-}

277{-# INLINE throwDecodeError #-}

256

278

257

279

280+#else

281+-- FFI version.

258

282

259−

260−{-

261import Control.Exception (evaluate, throw, try)

283import Control.Exception (evaluate, throw, try)

262import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)

284import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)

263import Data.ByteString as B

285import Data.ByteString as B

@@ -297,7 +319,8 @@ unescapeText' (PS fp off len) = runText $ \done -> do

297 where

319 where

298 desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"

320 desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"

299{-# INLINE unescapeText' #-}

321{-# INLINE unescapeText' #-}

300−-}

322+

323+#endif

301

324

302unescapeText :: ByteString -> Either UnicodeException Text

325unescapeText :: ByteString -> Either UnicodeException Text

303unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText'

326unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText'

aeson.cabal+8−1

@@ -70,6 +70,11 @@ flag bytestring-builder

70 default: False

71 manual: False

73+flag cffi

74+ description: Controls whether to include c-ffi bits or pure haskell

75+ default: True

76+ manual: True

77+

73library

78library

74 default-language: Haskell2010

79 default-language: Haskell2010

@@ -150,7 +155,9 @@ library

150 ghc-options: -O2

155 ghc-options: -O2

151

156

152 include-dirs: include

157 include-dirs: include

158+ if flag(cffi)

153− c-sources: cbits/unescape_string.c

159+ c-sources: cbits/unescape_string.c

160+ cpp-options: -DCFFI

154

161

155test-suite tests

162test-suite tests

156 default-language: Haskell2010

163 default-language: Haskell2010