git.iko.soy/elk
on master help sign in
Have a unified String representation
82d32c6Evan Czaplicki
compiler/src/Data/Name.hs+78−277
compare with master
unifiedsplit
@@ -1,19 +1,18 @@
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, MagicHash, OverloadedStrings, UnboxedTuples #-}
3module Data.Name
3module Data.Name
4 ( Name
4 ( Name
5− , length
6 , toUtf8
5 , toUtf8
7− , toBuilder
6+ , fromUtf8
8 , toEscapedBuilder
7 , toEscapedBuilder
9− , fromByteString
8+ , Utf8.toBuilder
10− , fromString
9+ , Utf8.fromPtr
11− -- ???
10+ , Utf8.fromChars
12− , toText
11+ , Utf8.toChars
13− , toString
12+ -- misc
14 , getKernel
13 , getKernel
15− , isKernel
16 , hasDot
14 , hasDot
15+ , isKernel
17 , isNumberType
16 , isNumberType
18 , isComparableType
17 , isComparableType
19 , isAppendableType
18 , isAppendableType
@@ -37,198 +36,48 @@ module Data.Name
37 where
36 where
38
37
39
38
39+import Prelude hiding (length, maybe, negate)
40import Control.Exception (assert)
40import Control.Exception (assert)
41−import Data.Binary (Binary(..), Get, getWord8, putWord8)
42−import Data.Binary.Put (putBuilder)
43−import Data.Binary.Get.Internal (readN)
44−import qualified Data.ByteString.Internal as B
45import qualified Data.ByteString.Builder.Internal as B
41import qualified Data.ByteString.Builder.Internal as B
42+import Data.Coerce (coerce)
46import qualified Data.List as List
43import qualified Data.List as List
47−import Data.String (IsString(..))
48−import qualified Data.Text as Text
49import qualified Data.Utf8 as Utf8
44import qualified Data.Utf8 as Utf8
50−import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
45+import Foreign.Ptr (plusPtr, minusPtr)
51−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
52−import Foreign.Ptr (minusPtr, plusPtr)
53import GHC.Exts
46import GHC.Exts
54− ( Int(I#), Ptr(Ptr), Char(C#)
47+ ( Int(I#), Ptr(Ptr)
55 , RealWorld
48 , RealWorld
56− , ByteArray#, MutableByteArray#
49+ , MutableByteArray#
57 , isTrue#
50 , isTrue#
58− , newByteArray#, unsafeFreezeByteArray#
51+ , newByteArray#
59 , sizeofByteArray#
52 , sizeofByteArray#
60− , writeCharArray#, writeWord8OffAddr#
53+ , writeWord8OffAddr#
61− , copyAddrToByteArray#, copyByteArrayToAddr#
54+ , copyByteArrayToAddr#
55+ , unsafeFreezeByteArray#
62 )
56 )
63import GHC.IO
57import GHC.IO
64import GHC.ST (ST(ST), runST)
58import GHC.ST (ST(ST), runST)
65import GHC.Prim
59import GHC.Prim
66import GHC.Word (Word8(W8#))
60import GHC.Word (Word8(W8#))
67−import Prelude hiding (length, maybe, negate)
68−
69−
70−
71−-- UTF-8
72−
73−
74−data Name =
75− Name ByteArray#
76−
77−
78−
79−-- LENGTH
80−
81−
82−length :: Name -> Int
83−length (Name ba#) =
84− I# (sizeofByteArray# ba#)
85−
86−
87−
88−-- EQUAL
89−
90−
91−instance Eq Name where
92− (==) (Name ba1#) (Name ba2#) =
93− let
94− !len1# = sizeofByteArray# ba1#
95− !len2# = sizeofByteArray# ba2#
96− in
97− isTrue# (len1# ==# len2#)
98− &&
99− isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#)
100−
101−
102−
103−-- COMPARE
104−
105−
106−-- TODO see if this can be written any faster
107−instance Ord Name where
108− compare (Name ba1#) (Name ba2#) =
109− let
110− !len1# = sizeofByteArray# ba1#
111− !len2# = sizeofByteArray# ba2#
112− !len# = if isTrue# (len1# <# len2#) then len1# else len2#
113− !cmp# = compareByteArrays# ba1# 0# ba2# 0# len#
114− in
115− case () of
116− _ | isTrue# (cmp# <# 0#) -> LT
117− | isTrue# (cmp# ># 0#) -> GT
118− | isTrue# (len1# <# len2#) -> LT
119− | isTrue# (len1# ># len2#) -> GT
120− | True -> EQ
121−
122−
123−
124−-- STRING OVERLOADING
125−
126−
127−instance IsString Name where
128− fromString str =
129− runST
130− (
131− do mba <- newByteArray (List.length str)
132− writeChars mba 0 str
133− unsafeFreeze mba
134− )
135−
136−
137−writeChars :: MBA s -> Int -> [Char] -> ST s ()
138−writeChars !mba !i chars =
139− case chars of
140− [] ->
141− return ()
142−
143− c:cs ->
144− do writeChar8 mba i c
145− writeChars mba (i+1) cs
146−
147−
148−
149−-- BINARY
150−
151−
152−instance Binary Name where
153− put name@(Name ba#) =
154− putWord8 (W8# (int2Word# (sizeofByteArray# ba#)))
155− >> putBuilder (toBuilder name)
156− get =
157− getWord8 >>= getName
158−
159−
160−{-# INLINE getName #-}
161−getName :: Word8 -> Get Name
162−getName w =
163− let !n = fromIntegral w in
164− readN n (copyFromByteString n)
165−
166−
167−{-# INLINE copyFromByteString #-}
168−copyFromByteString :: Int -> B.ByteString -> Name
169−copyFromByteString len (B.PS fptr offset _) =
170− unsafeDupablePerformIO
171− (
172− do mba <- stToIO (newByteArray len)
173− stToIO (copyFromPtr (unsafeForeignPtrToPtr fptr `plusPtr` offset) mba 0 len)
174− touchForeignPtr fptr
175− stToIO (unsafeFreeze mba)
176− )
177−
178−
179−
180−-- FROM BYTESTRING
181−
182−
183−fromByteString :: ForeignPtr Word8 -> Int -> Int -> Name
184−fromByteString fptr offset len =
185− unsafeDupablePerformIO
186− (
187− do mba <- stToIO (newByteArray len)
188− stToIO (copyFromPtr (unsafeForeignPtrToPtr fptr `plusPtr` offset) mba 0 len)
189− touchForeignPtr fptr
190− stToIO (unsafeFreeze mba)
191− )
192
61
193
62
194
63
195−-- TO UTF-8
64+-- NAME
196
65
197
66
198−{-# INLINE toUtf8 #-}
67+type Name = Utf8.Under256 NAME
199−toUtf8 :: Name -> Utf8.Utf8
200−toUtf8 (Name ba#) =
201− Utf8.Utf8 ba#
202
68
203
69
70+data NAME
204
71
205−-- TO BUILDER
206
72
73+toUtf8 :: Name -> Utf8.String
74+toUtf8 =
75+ coerce
207
76
208−{-# INLINE toBuilder #-}
209−toBuilder :: Name -> B.Builder
210−toBuilder =
211− \name -> B.builder (toBuilderHelp name)
212
77
213−
78+fromUtf8 :: Utf8.String -> Name
214−{-# INLINE toBuilderHelp #-}
79+fromUtf8 =
215−toBuilderHelp :: Name -> B.BuildStep a -> B.BuildStep a
80+ coerce
216−toBuilderHelp !name@(Name ba#) k =
217− go 0 (I# (sizeofByteArray# ba#))
218− where
219− go !offset !end !(B.BufferRange bOffset bEnd) =
220− let
221− !bLen = minusPtr bEnd bOffset
222− !len = end - offset
223− in
224− if len <= bLen then
225− do stToIO (copyToPtr name offset bOffset len)
226− let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
227− k newBufferRange
228− else
229− do stToIO (copyToPtr name offset bOffset bLen)
230− let !newOffset = offset + bLen
231− return $ B.bufferFull 1 bEnd (go newOffset end)
232
81
233
82
234
83
@@ -243,7 +92,7 @@ toEscapedBuilder before after =
243
92
244{-# INLINE toEscapedBuilderHelp #-}
93{-# INLINE toEscapedBuilderHelp #-}
245toEscapedBuilderHelp :: Word8 -> Word8 -> Name -> B.BuildStep a -> B.BuildStep a
94toEscapedBuilderHelp :: Word8 -> Word8 -> Name -> B.BuildStep a -> B.BuildStep a
246−toEscapedBuilderHelp before after !name@(Name ba#) k =
95+toEscapedBuilderHelp before after !name@(Utf8.Utf8 ba#) k =
247 go 0 (I# (sizeofByteArray# ba#))
96 go 0 (I# (sizeofByteArray# ba#))
248 where
97 where
249 go !offset !len !(B.BufferRange bOffset bEnd) =
98 go !offset !len !(B.BufferRange bOffset bEnd) =
@@ -265,7 +114,7 @@ toEscapedBuilderHelp before after !name@(Name ba#) k =
265
114
266
115
267escape :: Word8 -> Word8 -> Ptr a -> Name -> Int -> Int -> Int -> ST RealWorld ()
116escape :: Word8 -> Word8 -> Ptr a -> Name -> Int -> Int -> Int -> ST RealWorld ()
268−escape before@(W8# before#) after ptr name@(Name ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =
117+escape before@(W8# before#) after ptr name@(Utf8.Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =
269 if isTrue# (i# <# len#) then
118 if isTrue# (i# <# len#) then
270 if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))
119 if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))
271 then
120 then
@@ -279,44 +128,12 @@ escape before@(W8# before#) after ptr name@(Name ba#) offset@(I# offset#) len@(I
279
128
280
129
281
130
282−-- TO STRING
283−
284−
285−toString :: Name -> String
286−toString name =
287− Utf8.toString (toUtf8 name)
288−
289−
290−
291-- HAS DOT
131-- HAS DOT
292
132
293
133
294hasDot :: Name -> Bool
134hasDot :: Name -> Bool
295−hasDot (Name ba#) =
135+hasDot name =
296− let
136+ Utf8.contains 0x2E {- . -} (coerce name)
297− !len# = sizeofByteArray# ba#
298− in
299− hasDotHelp ba# 0# len#
300−
301−
302−hasDotHelp :: ByteArray# -> Int# -> Int# -> Bool
303−hasDotHelp ba# !offset# end# =
304− if isTrue# (offset# <# end#) then
305− if isTrue# (eqWord# 0x2E## {- . -} (indexWord8Array# ba# offset#))
306− then True
307− else hasDotHelp ba# (offset# +# 1#) end#
308−
309− else
310− False
311−
312−
313−
314−-- TO TEXT
315−
316−
317−toText :: Name -> Text.Text
318−toText name =
319− Text.pack (toString name) -- TODO get rid of this?
320
137
321
138
322
139
@@ -324,7 +141,7 @@ toText name =
324
141
325
142
326getKernel :: Name -> Name
143getKernel :: Name -> Name
327−getKernel name@(Name ba#) =
144+getKernel name@(Utf8.Utf8 ba#) =
328 assert (isKernel name)
145 assert (isKernel name)
329 (
146 (
330 runST
147 runST
@@ -338,7 +155,7 @@ getKernel name@(Name ba#) =
338 case copyByteArray# ba# 11# mba# 0# size# s of
155 case copyByteArray# ba# 11# mba# 0# size# s of
339 s ->
156 s ->
340 case unsafeFreezeByteArray# mba# s of
157 case unsafeFreezeByteArray# mba# s of
341− (# s, ba# #) -> (# s, Name ba# #)
158+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
342 )
159 )
343 )
160 )
344
161
@@ -347,32 +164,20 @@ getKernel name@(Name ba#) =
347-- STARTS WITH
164-- STARTS WITH
348
165
349
166
350−{-# INLINE startsWith #-}
351−startsWith :: Name -> Name -> Bool
352−startsWith (Name ba1#) (Name ba2#) =
353− let
354− !len1# = sizeofByteArray# ba1#
355− !len2# = sizeofByteArray# ba2#
356− in
357− isTrue# (len1# <=# len2#)
358− &&
359− isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#)
360−
361−
362isKernel :: Name -> Bool
167isKernel :: Name -> Bool
363−isKernel = startsWith prefix_kernel
168+isKernel = Utf8.startsWith prefix_kernel
364
169
365isNumberType :: Name -> Bool
170isNumberType :: Name -> Bool
366−isNumberType = startsWith prefix_number
171+isNumberType = Utf8.startsWith prefix_number
367
172
368isComparableType :: Name -> Bool
173isComparableType :: Name -> Bool
369−isComparableType = startsWith prefix_comparable
174+isComparableType = Utf8.startsWith prefix_comparable
370
175
371isAppendableType :: Name -> Bool
176isAppendableType :: Name -> Bool
372−isAppendableType = startsWith prefix_appendable
177+isAppendableType = Utf8.startsWith prefix_appendable
373
178
374isCompappendType :: Name -> Bool
179isCompappendType :: Name -> Bool
375−isCompappendType = startsWith prefix_compappend
180+isCompappendType = Utf8.startsWith prefix_compappend
376
181
377{-# NOINLINE prefix_kernel #-}
182{-# NOINLINE prefix_kernel #-}
378prefix_kernel :: Name
183prefix_kernel :: Name
@@ -396,7 +201,7 @@ prefix_compappend = "compappend"
396
201
397
202
398
203
399−-- FROM INDEX
204+-- FROM VAR INDEX
400
205
401
206
402fromVarIndex :: Int -> Name
207fromVarIndex :: Int -> Name
@@ -407,8 +212,8 @@ fromVarIndex n =
407 mba <- newByteArray size
212 mba <- newByteArray size
408 writeWord8 mba 0 0x5F {- _ -}
213 writeWord8 mba 0 0x5F {- _ -}
409 writeWord8 mba 1 0x76 {- v -}
214 writeWord8 mba 1 0x76 {- v -}
410− writeNumbers mba (size - 1) n
215+ writeDigits mba (size - 1) n
411− unsafeFreeze mba
216+ freeze mba
412 )
217 )
413
218
414
219
@@ -421,17 +226,21 @@ getIndexSize n
421
226
422
227
423
228
424−writeNumbers :: MBA s -> Int -> Int -> ST s ()
229+writeDigits :: MBA s -> Int -> Int -> ST s ()
425−writeNumbers !mba !offset !n =
230+writeDigits !mba !offset !n =
426 do let (q,r) = quotRem n 10
231 do let (q,r) = quotRem n 10
427 writeWord8 mba offset (0x30 + fromIntegral r)
232 writeWord8 mba offset (0x30 + fromIntegral r)
428 if q <= 0
233 if q <= 0
429 then return ()
234 then return ()
430− else writeNumbers mba (offset-1) q
235+ else writeDigits mba (offset-1) q
236+
237+
238+
239+-- FROM TYPE VARIABLE
431
240
432
241
433fromTypeVariable :: Name -> Int -> Name
242fromTypeVariable :: Name -> Int -> Name
434−fromTypeVariable name@(Name ba#) index =
243+fromTypeVariable name@(Utf8.Utf8 ba#) index =
435 if index <= 0 then
244 if index <= 0 then
436 name
245 name
437 else
246 else
@@ -442,24 +251,28 @@ fromTypeVariable name@(Name ba#) index =
442 if isTrue# (leWord# 0x30## end#) && isTrue# (leWord# end# 0x39##) then
251 if isTrue# (leWord# 0x30## end#) && isTrue# (leWord# end# 0x39##) then
443 runST
252 runST
444 (
253 (
445− do let !size = length name + 1 + getIndexSize index
254+ do let !size = I# len# + 1 + getIndexSize index
446 mba <- newByteArray size
255 mba <- newByteArray size
447 copyToMBA name mba
256 copyToMBA name mba
448 writeWord8 mba (I# len#) 0x5F {- _ -}
257 writeWord8 mba (I# len#) 0x5F {- _ -}
449− writeNumbers mba (size - 1) index
258+ writeDigits mba (size - 1) index
450− unsafeFreeze mba
259+ freeze mba
451 )
260 )
452 else
261 else
453 runST
262 runST
454 (
263 (
455− do let !size = length name + getIndexSize index
264+ do let !size = I# len# + getIndexSize index
456 mba <- newByteArray size
265 mba <- newByteArray size
457 copyToMBA name mba
266 copyToMBA name mba
458− writeNumbers mba (size - 1) index
267+ writeDigits mba (size - 1) index
459− unsafeFreeze mba
268+ freeze mba
460 )
269 )
461
270
462
271
272+
273+-- FROM TYPE VARIABLE SCHEME
274+
275+
463fromTypeVariableScheme :: Int -> Name
276fromTypeVariableScheme :: Int -> Name
464fromTypeVariableScheme scheme =
277fromTypeVariableScheme scheme =
465 runST
278 runST
@@ -467,20 +280,24 @@ fromTypeVariableScheme scheme =
467 if scheme < 26 then
280 if scheme < 26 then
468 do mba <- newByteArray 1
281 do mba <- newByteArray 1
469 writeWord8 mba 0 (0x61 + fromIntegral scheme)
282 writeWord8 mba 0 (0x61 + fromIntegral scheme)
470− unsafeFreeze mba
283+ freeze mba
471 else
284 else
472 do let (extra, letter) = quotRem scheme 26
285 do let (extra, letter) = quotRem scheme 26
473 let !size = getIndexSize extra
286 let !size = getIndexSize extra
474 mba <- newByteArray size
287 mba <- newByteArray size
475 writeWord8 mba 0 (0x61 + fromIntegral letter)
288 writeWord8 mba 0 (0x61 + fromIntegral letter)
476− writeNumbers mba (size - 1) extra
289+ writeDigits mba (size - 1) extra
477− unsafeFreeze mba
290+ freeze mba
478 )
291 )
479
292
480
293
294+
295+-- FROM REPL COUNT
296+
297+
481fromReplCount :: Int -> Name
298fromReplCount :: Int -> Name
482fromReplCount n =
299fromReplCount n =
483− fromString ("repl_value_" ++ show n)
300+ Utf8.fromChars ("repl_value_" ++ show n)
484
301
485
302
486
303
@@ -490,7 +307,7 @@ fromReplCount n =
490fromManyNames :: [Name] -> Name
307fromManyNames :: [Name] -> Name
491fromManyNames names =
308fromManyNames names =
492 let
309 let
493− !(I# size#) = sum (map (\(Name ba#) -> I# (sizeofByteArray# ba# +# 1#)) names)
310+ !(I# size#) = sum (map (\(Utf8.Utf8 ba#) -> I# (sizeofByteArray# ba# +# 1#)) names)
494 in
311 in
495 runST
312 runST
496 (
313 (
@@ -500,7 +317,7 @@ fromManyNames names =
500 case writeNames mba# 0# names s of
317 case writeNames mba# 0# names s of
501 s ->
318 s ->
502 case unsafeFreezeByteArray# mba# s of
319 case unsafeFreezeByteArray# mba# s of
503− (# s, ba# #) -> (# s, Name ba# #)
320+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
504 )
321 )
505
322
506
323
@@ -510,7 +327,7 @@ writeNames mba# !offset# names s =
510 [] ->
327 [] ->
511 s
328 s
512
329
513− (Name ba#) : names ->
330+ (Utf8.Utf8 ba#) : names ->
514 case writeWord8Array# mba# offset# 0x24## {- $ -} s of
331 case writeWord8Array# mba# offset# 0x24## {- $ -} s of
515 s ->
332 s ->
516 let
333 let
@@ -533,7 +350,7 @@ fromWords words =
533 (
350 (
534 do mba <- newByteArray (List.length words)
351 do mba <- newByteArray (List.length words)
535 writeWords mba 0 words
352 writeWords mba 0 words
536− unsafeFreeze mba
353+ freeze mba
537 )
354 )
538
355
539
356
@@ -553,7 +370,7 @@ writeWords !mba !i words =
553
370
554
371
555sepBy :: Word8 -> Name -> Name -> Name
372sepBy :: Word8 -> Name -> Name -> Name
556−sepBy (W8# sep#) (Name ba1#) (Name ba2#) =
373+sepBy (W8# sep#) (Utf8.Utf8 ba1#) (Utf8.Utf8 ba2#) =
557 let
374 let
558 !len1# = sizeofByteArray# ba1#
375 !len1# = sizeofByteArray# ba1#
559 !len2# = sizeofByteArray# ba2#
376 !len2# = sizeofByteArray# ba2#
@@ -570,7 +387,7 @@ sepBy (W8# sep#) (Name ba1#) (Name ba2#) =
570 case copyByteArray# ba2# 0# mba# (len1# +# 1#) len2# s of
387 case copyByteArray# ba2# 0# mba# (len1# +# 1#) len2# s of
571 s ->
388 s ->
572 case unsafeFreezeByteArray# mba# s of
389 case unsafeFreezeByteArray# mba# s of
573− (# s, ba# #) -> (# s, Name ba# #)
390+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
574 )
391 )
575
392
576
393
@@ -590,20 +407,12 @@ newByteArray (I# len#) =
590 (# s, mba# #) -> (# s, MBA# mba# #)
407 (# s, mba# #) -> (# s, MBA# mba# #)
591
408
592
409
593−{-# INLINE unsafeFreeze #-}
410+{-# INLINE freeze #-}
594−unsafeFreeze :: MBA s -> ST s Name
411+freeze :: MBA s -> ST s Name
595−unsafeFreeze (MBA# mba#) =
412+freeze (MBA# mba#) =
596 ST $ \s ->
413 ST $ \s ->
597 case unsafeFreezeByteArray# mba# s of
414 case unsafeFreezeByteArray# mba# s of
598− (# s, ba# #) -> (# s, Name ba# #)
415+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
599−
600−
601−{-# INLINE writeChar8 #-}
602−writeChar8 :: MBA s -> Int -> Char -> ST s ()
603−writeChar8 (MBA# mba#) (I# offset#) (C# char#) =
604− ST $ \s ->
605− case writeCharArray# mba# offset# char# s of
606− s -> (# s, () #)
607
416
608
417
609{-# INLINE writeWord8 #-}
418{-# INLINE writeWord8 #-}
@@ -622,17 +431,9 @@ writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =
622 s -> (# s, () #)
431 s -> (# s, () #)
623
432
624
433
625−{-# INLINE copyFromPtr #-}
626−copyFromPtr :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld ()
627−copyFromPtr (Ptr addr#) (MBA# mba#) (I# offset#) (I# len#) =
628− ST $ \s ->
629− case copyAddrToByteArray# addr# mba# offset# len# s of
630− s -> (# s, () #)
631−
632−
633{-# INLINE copyToPtr #-}
434{-# INLINE copyToPtr #-}
634copyToPtr :: Name -> Int -> Ptr a -> Int -> ST RealWorld ()
435copyToPtr :: Name -> Int -> Ptr a -> Int -> ST RealWorld ()
635−copyToPtr (Name ba#) (I# offset#) (Ptr addr#) (I# len#) =
436+copyToPtr (Utf8.Utf8 ba#) (I# offset#) (Ptr addr#) (I# len#) =
636 ST $ \s ->
437 ST $ \s ->
637 case copyByteArrayToAddr# ba# offset# addr# len# s of
438 case copyByteArrayToAddr# ba# offset# addr# len# s of
638 s -> (# s, () #)
439 s -> (# s, () #)
@@ -640,7 +441,7 @@ copyToPtr (Name ba#) (I# offset#) (Ptr addr#) (I# len#) =
640
441
641{-# INLINE copyToMBA #-}
442{-# INLINE copyToMBA #-}
642copyToMBA :: Name -> MBA s -> ST s ()
443copyToMBA :: Name -> MBA s -> ST s ()
643−copyToMBA (Name ba#) (MBA# mba#) =
444+copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
644 ST $ \s ->
445 ST $ \s ->
645 case copyByteArray# ba# 0# mba# 0# (sizeofByteArray# ba#) s of
446 case copyByteArray# ba# 0# mba# 0# (sizeofByteArray# ba#) s of
646 s -> (# s, () #)
447 s -> (# s, () #)
compiler/src/Data/Utf8.hs+561−146
@@ -1,22 +1,45 @@
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
3module Data.Utf8
3module Data.Utf8
4+ ( String
4− ( Utf8(..)
5+ , Utf8(..)
5− , toString
6+ , VeryLong
7+ , Under256
8+ , isEmpty
9+ , size
10+ , contains
11+ , containsDouble
12+ , startsWith
13+ , startsWithChar
14+ , endsWithWord
15+ , split
16+ , join
17+ , all
18+ , any
19+ , toWord16
20+ , fromWord16
21+ -- conversions
22+ , fromChars
23+ , toChars
6 , toBuilder
24 , toBuilder
25+ , fromPtr
7 , fromChunks
26 , fromChunks
8 , Chunk(..)
27 , Chunk(..)
9 )
28 )
10 where
29 where
11
30
12
31
32+import Prelude hiding (String, all, any, concat)
13−import Data.Binary (Binary(..), Get)
33+import Data.Binary (Binary(..), Get, getWord8, putWord8)
14import Data.Binary.Put (putBuilder)
34import Data.Binary.Put (putBuilder)
15import Data.Binary.Get.Internal (readN)
35import Data.Binary.Get.Internal (readN)
16import Data.Bits ((.&.), shiftR)
36import Data.Bits ((.&.), shiftR)
17import qualified Data.ByteString.Internal as B
37import qualified Data.ByteString.Internal as B
18import qualified Data.ByteString.Builder.Internal as B
38import qualified Data.ByteString.Builder.Internal as B
39+import qualified Data.Char as Char
40+import qualified Data.List as List
41+import Data.String (IsString(..))
19−import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
42+import Foreign.ForeignPtr (touchForeignPtr)
20import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
43import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
21import Foreign.Ptr (minusPtr, plusPtr)
44import Foreign.Ptr (minusPtr, plusPtr)
22import GHC.Exts
45import GHC.Exts
@@ -24,30 +47,261 @@ import GHC.Exts
24 , RealWorld
47 , RealWorld
25 , ByteArray#, MutableByteArray#
48 , ByteArray#, MutableByteArray#
26 , isTrue#
49 , isTrue#
50+ , newByteArray#
27− , newByteArray#, unsafeFreezeByteArray#
51+ , unsafeFreezeByteArray#
28 , sizeofByteArray#
52 , sizeofByteArray#
53+ , copyByteArray#
29− , copyAddrToByteArray#, copyByteArrayToAddr#
54+ , copyAddrToByteArray#
55+ , copyByteArrayToAddr#
30 , writeWord8Array#,
56 , writeWord8Array#,
31 )
57 )
32import GHC.IO
58import GHC.IO
33import GHC.ST (ST(ST), runST)
59import GHC.ST (ST(ST), runST)
34import GHC.Prim
60import GHC.Prim
35−import GHC.Word (Word8(W8#))
61+import GHC.Word (Word8(W8#), Word16(W16#))
36
62
37
63
38
64
39-- UTF-8
65-- UTF-8
40
66
41
67
42−data Utf8 =
68+data Utf8 size tipe =
43 Utf8 ByteArray#
69 Utf8 ByteArray#
44
70
45
71
72+type String = Utf8 VERY_LONG STRING
73+type VeryLong t = Utf8 VERY_LONG t
74+type Under256 t = Utf8 UNDER_256 t
75+
76+data STRING
77+data VERY_LONG
78+data UNDER_256
79+
80+
81+
82+-- IS EMPTY
83+
84+
85+isEmpty :: Utf8 l t -> Bool
86+isEmpty (Utf8 ba#) =
87+ isTrue# (sizeofByteArray# ba# ==# 0#)
88+
89+
90+
91+-- SIZE
92+
93+
94+size :: Utf8 l t -> Int
95+size (Utf8 ba#) =
96+ I# (sizeofByteArray# ba#)
97+
98+
99+
100+-- CONTAINS
101+
102+
103+contains :: Word8 -> Utf8 l t -> Bool
104+contains (W8# word#) (Utf8 ba#) =
105+ containsHelp word# ba# 0# (sizeofByteArray# ba#)
106+
107+
108+containsHelp :: Word# -> ByteArray# -> Int# -> Int# -> Bool
109+containsHelp word# ba# !offset# len# =
110+ if isTrue# (offset# <# len#) then
111+ if isTrue# (eqWord# word# (indexWord8Array# ba# offset#))
112+ then True
113+ else containsHelp word# ba# (offset# +# 1#) len#
114+ else
115+ False
116+
117+
118+
119+-- CONTAINS DOUBLE
120+
121+
122+containsDouble :: Word8 -> Utf8 l t -> Bool
123+containsDouble (W8# word#) (Utf8 ba#) =
124+ containsDoubleHelp word# ba# 0# (sizeofByteArray# ba#)
125+
126+
127+containsDoubleHelp :: Word# -> ByteArray# -> Int# -> Int# -> Bool
128+containsDoubleHelp word# ba# !offset# len# =
129+ let !offset1# = offset# +# 1# in
130+ if isTrue# (offset1# <# len#) then
131+ if isTrue# (eqWord# word# (indexWord8Array# ba# offset# ))
132+ && isTrue# (eqWord# word# (indexWord8Array# ba# offset1#))
133+ then True
134+ else containsDoubleHelp word# ba# (offset# +# 1#) len#
135+ else
136+ False
137+
138+
139+
140+-- STARTS WITH
141+
142+
143+{-# INLINE startsWith #-}
144+startsWith :: Utf8 l t -> Utf8 l t -> Bool
145+startsWith (Utf8 ba1#) (Utf8 ba2#) =
146+ let
147+ !len1# = sizeofByteArray# ba1#
148+ !len2# = sizeofByteArray# ba2#
149+ in
150+ isTrue# (len1# <=# len2#)
151+ &&
152+ isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#)
153+
154+
155+
156+-- STARTS WITH CHAR
157+
158+
159+startsWithChar :: (Char -> Bool) -> Utf8 l t -> Bool
160+startsWithChar isGood str@(Utf8 ba#) =
161+ if isEmpty str then
162+ False
163+ else
164+ let
165+ !w# = indexWord8Array# ba# 0#
166+ !char
167+ | isTrue# (ltWord# w# 0xC0##) = C# (chr# (word2Int# w#))
168+ | isTrue# (ltWord# w# 0xE0##) = chr2 ba# 0# w#
169+ | isTrue# (ltWord# w# 0xF0##) = chr3 ba# 0# w#
170+ | True = chr4 ba# 0# w#
171+ in
172+ isGood char
173+
174+
175+
176+-- ENDS WITH WORD
177+
178+
179+endsWithWord :: Word8 -> Utf8 l t -> Bool
180+endsWithWord (W8# w#) (Utf8 ba#) =
181+ let len# = sizeofByteArray# ba# in
182+ isTrue# (len# ># 0#)
183+ &&
184+ isTrue# (eqWord# w# (indexWord8Array# ba# (len# -# 1#)))
185+
186+
187+
188+-- SPLIT
189+
190+
191+split :: Word8 -> String -> [String]
192+split (W8# divider#) str@(Utf8 ba#) =
193+ splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])
194+
195+
196+splitHelp :: String -> Int -> [Int] -> [String]
197+splitHelp str start offsets =
198+ case offsets of
199+ [] ->
200+ [ unsafeSlice str start (size str) ]
201+
202+ offset : offsets ->
203+ unsafeSlice str start offset : splitHelp str (offset + 1) offsets
204+
205+
206+findDividers :: Word# -> ByteArray# -> Int# -> Int# -> [Int] -> [Int]
207+findDividers divider# ba# !offset# len# revOffsets =
208+ if isTrue# (offset# <# len#) then
209+ findDividers divider# ba# (offset# +# 1#) len# $
210+ if isTrue# (eqWord# divider# (indexWord8Array# ba# offset#))
211+ then I# offset# : revOffsets
212+ else revOffsets
213+ else
214+ reverse revOffsets
215+
216+
217+unsafeSlice :: String -> Int -> Int -> String
218+unsafeSlice str start end =
219+ let !len = end - start in
220+ if len == 0 then
221+ empty
222+ else
223+ runST $
224+ do mba <- newByteArray len
225+ copy str start mba 0 len
226+ freeze mba
227+
228+
229+
230+-- JOIN
231+
232+
233+join :: Word8 -> [String] -> String
234+join sep strings =
235+ case strings of
236+ [] ->
237+ empty
238+
239+ str:strs ->
240+ runST $
241+ do let !len = List.foldl' (\w s -> w + 1 + size s) (size str) strs
242+ mba <- newByteArray len
243+ joinHelp sep mba 0 str strs
244+ freeze mba
245+
246+
247+joinHelp :: Word8 -> MBA s -> Int -> String -> [String] -> ST s ()
248+joinHelp sep mba offset str strings =
249+ let
250+ !len = size str
251+ in
252+ case strings of
253+ [] ->
254+ copy str 0 mba offset len
255+
256+ s:ss ->
257+ do copy str 0 mba offset len
258+ let !dotOffset = offset + len
259+ writeWord8 mba dotOffset sep
260+ let !newOffset = dotOffset + 1
261+ joinHelp sep mba newOffset s ss
262+
263+
264+
265+-- ALL
266+
267+
268+all :: (Char -> Bool) -> Utf8 l t -> Bool
269+all isGood utf8 =
270+ not (any (not . isGood) utf8)
271+
272+
273+
274+-- ANY
275+
276+
277+any :: (Char -> Bool) -> Utf8 l t -> Bool
278+any isGood (Utf8 ba#) =
279+ anyHelp isGood ba# 0# (sizeofByteArray# ba#)
280+
281+
282+anyHelp :: (Char -> Bool) -> ByteArray# -> Int# -> Int# -> Bool
283+anyHelp isGood ba# offset# len# =
284+ if isTrue# (offset# >=# len#) then
285+ False
286+ else
287+ let
288+ !w# = indexWord8Array# ba# offset#
289+ !(# char, width# #)
290+ | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #)
291+ | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #)
292+ | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #)
293+ | True = (# chr4 ba# offset# w#, 4# #)
294+ in
295+ if isGood char
296+ then True
297+ else anyHelp isGood ba# (offset# +# width#) len#
298+
299+
46
300
47-- EQUAL
301-- EQUAL
48
302
49
303
50−instance Eq Utf8 where
304+instance Eq (Utf8 l t) where
51 (==) (Utf8 ba1#) (Utf8 ba2#) =
305 (==) (Utf8 ba1#) (Utf8 ba2#) =
52 let
306 let
53 !len1# = sizeofByteArray# ba1#
307 !len1# = sizeofByteArray# ba1#
@@ -62,7 +316,7 @@ instance Eq Utf8 where
62-- COMPARE
316-- COMPARE
63
317
64
318
65−instance Ord Utf8 where
319+instance Ord (Utf8 l t) where
66 compare (Utf8 ba1#) (Utf8 ba2#) =
320 compare (Utf8 ba1#) (Utf8 ba2#) =
67 let
321 let
68 !len1# = sizeofByteArray# ba1#
322 !len1# = sizeofByteArray# ba1#
@@ -79,63 +333,257 @@ instance Ord Utf8 where
79
333
80
334
81
335
82−-- BINARY
336+-- TO WORD16
83
337
84
338
85−instance Binary Utf8 where
339+toWord16 :: String -> Maybe Word16
86− put utf8@(Utf8 ba#) =
340+toWord16 (Utf8 ba#) =
87− put (I# (sizeofByteArray# ba#)) <> putBuilder (toBuilder utf8)
341+ let !len# = sizeofByteArray# ba# in
88− get =
342+ if isTrue# (len# ==# 0#) then
89− get >>= getUtf8
343+ Nothing
344+ else
345+ let !w# = indexWord8Array# ba# 0# in
346+ if isTrue# (eqWord# w# 0x30##) then
347+ if isTrue# (len# ==# 1#) then Just 0 else Nothing
348+ else
349+ toWordHelp ba# 0# len# 0##
350+
351+
352+toWordHelp :: ByteArray# -> Int# -> Int# -> Word# -> Maybe Word16
353+toWordHelp ba# offset# len# number# =
354+ if isTrue# (offset# <# len#) then
355+ let !w# = indexWord8Array# ba# offset# in
356+ if isTrue# (leWord# w# 0x39##) && isTrue# (geWord# w# 0x30##) then
357+ let !newNumber# = plusWord# (timesWord# 10## number#) (minusWord# w# 0x30##) in
358+ toWordHelp ba# (offset# +# 1#) len# newNumber#
359+ else
360+ Nothing
361+ else
362+ Just (W16# number#)
363+
364+
365+
366+-- FROM WORD16
367+
368+
369+fromWord16 :: Word16 -> String
370+fromWord16 n =
371+ runST $
372+ do let !size = getWordSize n
373+ mba <- newByteArray size
374+ writeDigits mba (size - 1) n
375+ freeze mba
376+
377+
378+getWordSize :: Word16 -> Int
379+getWordSize n
380+ | n < 10 = 1
381+ | n < 100 = 2
382+ | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)
383+
384+
385+writeDigits :: MBA s -> Int -> Word16 -> ST s ()
386+writeDigits !mba !offset !n =
387+ do let (q,r) = quotRem n 10
388+ writeWord8 mba offset (0x30 + fromIntegral r)
389+ if q <= 0
390+ then return ()
391+ else writeDigits mba (offset-1) q
392+
393+
394+
395+-- FROM STRING
90
396
91
397
398+fromChars :: [Char] -> Utf8 l t
399+fromChars =
400+ fromString
401+
402+
403+instance IsString (Utf8 l t) where
404+ fromString str =
405+ runST
406+ (
407+ do mba <- newByteArray (sum (map getWidth str))
408+ writeString mba 0 str
409+ )
410+
411+
412+writeString :: MBA s -> Int -> [Char] -> ST s (Utf8 l t)
413+writeString !mba !offset chars =
414+ case chars of
415+ [] ->
416+ freeze mba
417+
418+ char : chars
419+ | n < 0x80 ->
420+ do writeWord8 mba (offset ) (fromIntegral n)
421+ writeString mba (offset + 1) chars
422+
423+ | n < 0x800 ->
424+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))
425+ writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))
426+ writeString mba (offset + 2) chars
427+
428+ | n < 0x10000 ->
429+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))
430+ writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
431+ writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))
432+ writeString mba (offset + 3) chars
433+
434+ | otherwise ->
435+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))
436+ writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))
437+ writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
438+ writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))
439+ writeString mba (offset + 4) chars
440+
441+ where
442+ n = Char.ord char
443+
444+
92−{-# INLINE getUtf8 #-}
445+{-# INLINE getWidth #-}
93−getUtf8 :: Int -> Get Utf8
446+getWidth :: Char -> Int
94−getUtf8 n =
447+getWidth char
448+ | code < 0x80 = 1
449+ | code < 0x800 = 2
450+ | code < 0x10000 = 3
451+ | otherwise = 4
452+ where
453+ code = Char.ord char
454+
455+
456+
457+-- TO STRING
458+
459+
460+toChars :: Utf8 l t -> [Char]
461+toChars (Utf8 ba#) =
462+ toCharsHelp ba# 0# (sizeofByteArray# ba#)
463+
464+
465+toCharsHelp :: ByteArray# -> Int# -> Int# -> [Char]
466+toCharsHelp ba# offset# len# =
95− if n > 0 then
467+ if isTrue# (offset# >=# len#) then
96− readN n (copyFromByteString n)
468+ []
97 else
469 else
98− return empty
470+ let
471+ !w# = indexWord8Array# ba# offset#
472+ !(# char, width# #)
473+ | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #)
474+ | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #)
475+ | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #)
476+ | True = (# chr4 ba# offset# w#, 4# #)
99
477
478+ !newOffset# = offset# +# width#
479+ in
480+ char : toCharsHelp ba# newOffset# len#
100
481
101−-- TODO add inline?
102−copyFromByteString :: Int -> B.ByteString -> Utf8
103−copyFromByteString len (B.PS fptr offset _) =
104− unsafeDupablePerformIO
105− (
106− do mba <- stToIO (newByteArray len)
107− stToIO (copyFromPtr (unsafeForeignPtrToPtr fptr `plusPtr` offset) mba 0 len)
108− touchForeignPtr fptr
109− stToIO (unsafeFreeze mba)
110− )
111
482
483+{-# INLINE chr2 #-}
484+chr2 :: ByteArray# -> Int# -> Word# -> Char
485+chr2 ba# offset# firstWord# =
486+ let
487+ !i1# = word2Int# firstWord#
488+ !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))
489+ !c1# = uncheckedIShiftL# (i1# -# 0xC0#) 6#
490+ !c2# = i2# -# 0x80#
491+ in
492+ C# (chr# (c1# +# c2#))
112
493
113−{-# NOINLINE empty #-}
494+
114−empty :: Utf8
495+{-# INLINE chr3 #-}
115−empty =
496+chr3 :: ByteArray# -> Int# -> Word# -> Char
116− runST (unsafeFreeze =<< newByteArray 0)
497+chr3 ba# offset# firstWord# =
498+ let
499+ !i1# = word2Int# firstWord#
500+ !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))
501+ !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#))
502+ !c1# = uncheckedIShiftL# (i1# -# 0xE0#) 12#
503+ !c2# = uncheckedIShiftL# (i2# -# 0x80#) 6#
504+ !c3# = i3# -# 0x80#
505+ in
506+ C# (chr# (c1# +# c2# +# c3#))
507+
508+
509+{-# INLINE chr4 #-}
510+chr4 :: ByteArray# -> Int# -> Word# -> Char
511+chr4 ba# offset# firstWord# =
512+ let
513+ !i1# = word2Int# firstWord#
514+ !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))
515+ !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#))
516+ !i4# = word2Int# (indexWord8Array# ba# (offset# +# 3#))
517+ !c1# = uncheckedIShiftL# (i1# -# 0xF0#) 18#
518+ !c2# = uncheckedIShiftL# (i2# -# 0x80#) 12#
519+ !c3# = uncheckedIShiftL# (i3# -# 0x80#) 6#
520+ !c4# = i4# -# 0x80#
521+ in
522+ C# (chr# (c1# +# c2# +# c3# +# c4#))
523+
524+
525+
526+-- TO BUILDER
527+
528+
529+{-# INLINE toBuilder #-}
530+toBuilder :: Utf8 l t -> B.Builder
531+toBuilder =
532+ \bytes -> B.builder (toBuilderHelp bytes)
533+
534+
535+{-# INLINE toBuilderHelp #-}
536+toBuilderHelp :: Utf8 l t -> B.BuildStep a -> B.BuildStep a
537+toBuilderHelp !bytes@(Utf8 ba#) k =
538+ go 0 (I# (sizeofByteArray# ba#))
539+ where
540+ go !offset !end !(B.BufferRange bOffset bEnd) =
541+ let
542+ !bLen = minusPtr bEnd bOffset
543+ !len = end - offset
544+ in
545+ if len <= bLen then
546+ do copyToPtr bytes offset bOffset len
547+ let !br' = B.BufferRange (plusPtr bOffset len) bEnd
548+ k br'
549+ else
550+ do copyToPtr bytes offset bOffset bLen
551+ let !offset' = offset + bLen
552+ return $ B.bufferFull 1 bEnd (go offset' end)
553+
554+
555+
556+-- FROM PTR
117
557
118
558
559+fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 l t
560+fromPtr pos end =
561+ unsafeDupablePerformIO (stToIO (
562+ do let !len = minusPtr end pos
563+ mba <- newByteArray len
564+ copyFromPtr pos mba 0 len
565+ freeze mba
566+ ))
119
567
568+
569+
120−-- CHUNKS
570+-- FROM CHUNKS
121
571
122
572
123data Chunk
573data Chunk
124− = Slice Int Int -- TODO try UNPACK
574+ = Slice (Ptr Word8) Int
125 | Escape Word8
575 | Escape Word8
126 | CodePoint Int
576 | CodePoint Int
127
577
128
578
129−fromChunks :: ForeignPtr Word8 -> [Chunk] -> Utf8
579+fromChunks :: [Chunk] -> Utf8 l t
130−fromChunks fptr chunks =
580+fromChunks chunks =
131− unsafeDupablePerformIO
581+ unsafeDupablePerformIO (stToIO (
132− (
133 do let !len = sum (map chunkToWidth chunks)
582 do let !len = sum (map chunkToWidth chunks)
134− mba <- stToIO (newByteArray len)
583+ mba <- newByteArray len
135− stToIO (writeChunks (unsafeForeignPtrToPtr fptr) mba 0 chunks)
584+ writeChunks mba 0 chunks
136− touchForeignPtr fptr
585+ freeze mba
137− stToIO (unsafeFreeze mba)
138− )
586+ ))
139
587
140
588
141chunkToWidth :: Chunk -> Int
589chunkToWidth :: Chunk -> Int
@@ -151,36 +599,36 @@ chunkToWidth chunk =
151 if code < 0xFFFF then 6 else 12
599 if code < 0xFFFF then 6 else 12
152
600
153
601
154−writeChunks :: Ptr Word8 -> MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
602+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
155−writeChunks ptr mba offset chunks =
603+writeChunks mba offset chunks =
156 case chunks of
604 case chunks of
157 [] ->
605 [] ->
158 return ()
606 return ()
159
607
160 chunk : chunks ->
608 chunk : chunks ->
161 case chunk of
609 case chunk of
162− Slice off len ->
610+ Slice ptr len ->
163− do copyFromPtr (plusPtr ptr off) mba offset len
611+ do copyFromPtr ptr mba offset len
164 let !newOffset = offset + len
612 let !newOffset = offset + len
165− writeChunks ptr mba newOffset chunks
613+ writeChunks mba newOffset chunks
166
614
167 Escape word ->
615 Escape word ->
168 do writeWord8 mba offset 0x5C {- \ -}
616 do writeWord8 mba offset 0x5C {- \ -}
169 writeWord8 mba (offset + 1) word
617 writeWord8 mba (offset + 1) word
170 let !newOffset = offset + 2
618 let !newOffset = offset + 2
171− writeChunks ptr mba newOffset chunks
619+ writeChunks mba newOffset chunks
172
620
173 CodePoint code ->
621 CodePoint code ->
174 if code < 0xFFFF then
622 if code < 0xFFFF then
175 do writeCode mba offset code
623 do writeCode mba offset code
176 let !newOffset = offset + 6
624 let !newOffset = offset + 6
177− writeChunks ptr mba newOffset chunks
625+ writeChunks mba newOffset chunks
178 else
626 else
179 do let (hi,lo) = divMod (code - 0x10000) 0x400
627 do let (hi,lo) = divMod (code - 0x10000) 0x400
180 writeCode mba (offset ) (hi + 0xD800)
628 writeCode mba (offset ) (hi + 0xD800)
181 writeCode mba (offset + 6) (lo + 0xDC00)
629 writeCode mba (offset + 6) (lo + 0xDC00)
182 let !newOffset = offset + 12
630 let !newOffset = offset + 12
183− writeChunks ptr mba newOffset chunks
631+ writeChunks mba newOffset chunks
184
632
185
633
186-- TODO see if it is faster to writeWord32 a block of hex-as-ascii
634-- TODO see if it is faster to writeWord32 a block of hex-as-ascii
@@ -201,105 +649,64 @@ writeHex mba !offset !bits =
201
649
202
650
203
651
204−-- TO BUILDER
652+-- UNDER 256 BINARY
205
653
206
654
207−{-# INLINE toBuilder #-}
655+instance Binary (Utf8 UNDER_256 t) where
208−toBuilder :: Utf8 -> B.Builder
656+ put bytes@(Utf8 ba#) =
657+ do putWord8 (W8# (int2Word# (sizeofByteArray# ba#)))
209−toBuilder =
658+ putBuilder (toBuilder bytes)
210− \utf8 -> B.builder (toBuilderHelp utf8)
659+ get =
660+ getUnder256 =<< getWord8
211
661
212
662
213−{-# INLINE toBuilderHelp #-}
663+{-# INLINE getUnder256 #-}
214−toBuilderHelp :: Utf8 -> B.BuildStep a -> B.BuildStep a
664+getUnder256 :: Word8 -> Get (Utf8 UNDER_256 t)
215−toBuilderHelp !utf8@(Utf8 ba#) k =
665+getUnder256 w =
216− go 0 (I# (sizeofByteArray# ba#))
666+ let !n = fromIntegral w in
217− where
667+ readN n (copyFromByteString n)
218− go !offset !end !(B.BufferRange bOffset bEnd) =
219− let
220− !bLen = minusPtr bEnd bOffset
221− !len = end - offset
222− in
223− if len <= bLen then
224− do stToIO (copyToPtr utf8 offset bOffset len)
225− let !br' = B.BufferRange (plusPtr bOffset len) bEnd
226− k br'
227− else
228− do stToIO (copyToPtr utf8 offset bOffset bLen)
229− let !offset' = offset + bLen
230− return $ B.bufferFull 1 bEnd (go offset' end)
231
668
232
669
233
670
234−-- TO STRING
671+-- VERY LONG BINARY
235
672
236
673
237−toString :: Utf8 -> String
674+instance Binary (Utf8 VERY_LONG t) where
238−toString (Utf8 ba#) =
675+ put str =
239− let
676+ do put (size str)
240− !len# = sizeofByteArray# ba#
677+ putBuilder (toBuilder str)
241− in
678+ get =
242− toStringHelp ba# 0# len#
679+ getVeryLong =<< get
243
680
244
681
245−toStringHelp :: ByteArray# -> Int# -> Int# -> String
682+{-# INLINE getVeryLong #-}
246−toStringHelp ba# offset# len# =
683+getVeryLong :: Int -> Get (Utf8 VERY_LONG t)
247− if isTrue# (offset# >=# len#) then
684+getVeryLong n =
248− []
685+ if n > 0
686+ then readN n (copyFromByteString n)
249− else
687+ else return empty
250− let
251− !w# = indexWord8Array# ba# offset#
252− !(# char, width# #)
253− | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #)
254− | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #)
255− | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #)
256− | True = (# chr4 ba# offset# w#, 4# #)
257
688
258− !newOffset# = offset# +# width#
259− in
260− char : toStringHelp ba# newOffset# len#
261
689
690+{-# NOINLINE empty #-}
691+empty :: Utf8 l t
692+empty =
693+ runST (freeze =<< newByteArray 0)
262
694
263−{-# INLINE chr2 #-}
264−chr2 :: ByteArray# -> Int# -> Word# -> Char
265−chr2 ba# offset# firstWord# =
266− let
267− !i1# = word2Int# firstWord#
268− !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))
269− !c1# = uncheckedIShiftL# (i1# -# 0xC0#) 6#
270− !c2# = i2# -# 0x80#
271− in
272− C# (chr# (c1# +# c2#))
273
695
274
696
275−{-# INLINE chr3 #-}
697+-- COPY FROM BYTESTRING
276−chr3 :: ByteArray# -> Int# -> Word# -> Char
277−chr3 ba# offset# firstWord# =
278− let
279− !i1# = word2Int# firstWord#
280− !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))
281− !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#))
282− !c1# = uncheckedIShiftL# (i1# -# 0xE0#) 12#
283− !c2# = uncheckedIShiftL# (i2# -# 0x80#) 6#
284− !c3# = i3# -# 0x80#
285− in
286− C# (chr# (c1# +# c2# +# c3#))
287
698
288
699
289−{-# INLINE chr4 #-}
700+{-# INLINE copyFromByteString #-}
290−chr4 :: ByteArray# -> Int# -> Word# -> Char
701+copyFromByteString :: Int -> B.ByteString -> Utf8 l t
291−chr4 ba# offset# firstWord# =
702+copyFromByteString len (B.PS fptr offset _) =
292− let
703+ unsafeDupablePerformIO
293− !i1# = word2Int# firstWord#
704+ (
294− !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))
705+ do mba <- stToIO (newByteArray len)
295− !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#))
706+ stToIO (copyFromPtr (unsafeForeignPtrToPtr fptr `plusPtr` offset) mba 0 len)
296− !i4# = word2Int# (indexWord8Array# ba# (offset# +# 3#))
707+ touchForeignPtr fptr
297− !c1# = uncheckedIShiftL# (i1# -# 0xF0#) 18#
708+ stToIO (freeze mba)
298− !c2# = uncheckedIShiftL# (i2# -# 0x80#) 12#
709+ )
299− !c3# = uncheckedIShiftL# (i3# -# 0x80#) 6#
300− !c4# = i4# -# 0x80#
301− in
302− C# (chr# (c1# +# c2# +# c3# +# c4#))
303
710
304
711
305
712
@@ -310,36 +717,44 @@ data MBA s =
310 MBA# (MutableByteArray# s)
717 MBA# (MutableByteArray# s)
311
718
312
719
313−newByteArray :: Int -> ST s (MBA s)
720+newByteArray :: Int -> ST s (MBA s) -- TODO see if newPinnedByteArray for len > 256 is positive
314newByteArray (I# len#) =
721newByteArray (I# len#) =
315 ST $ \s ->
722 ST $ \s ->
316 case newByteArray# len# s of
723 case newByteArray# len# s of
317 (# s, mba# #) -> (# s, MBA# mba# #)
724 (# s, mba# #) -> (# s, MBA# mba# #)
318
725
319
726
320−unsafeFreeze :: MBA s -> ST s Utf8
727+freeze :: MBA s -> ST s (Utf8 l t)
321−unsafeFreeze (MBA# mba#) =
728+freeze (MBA# mba#) =
322 ST $ \s ->
729 ST $ \s ->
323 case unsafeFreezeByteArray# mba# s of
730 case unsafeFreezeByteArray# mba# s of
324 (# s, ba# #) -> (# s, Utf8 ba# #)
731 (# s, ba# #) -> (# s, Utf8 ba# #)
325
732
326
733
734+copy :: Utf8 l t -> Int -> MBA s -> Int -> Int -> ST s ()
735+copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =
736+ ST $ \s ->
737+ case copyByteArray# ba# offset# mba# i# len# s of
738+ s -> (# s, () #)
739+
740+
327copyFromPtr :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld ()
741copyFromPtr :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld ()
328−copyFromPtr (Ptr src#) (MBA# mba#) (I# dst_off#) (I# len#) =
742+copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =
329 ST $ \s ->
743 ST $ \s ->
330− case copyAddrToByteArray# src# mba# dst_off# len# s of
744+ case copyAddrToByteArray# src# mba# offset# len# s of
331 s -> (# s, () #)
745 s -> (# s, () #)
332
746
333
747
334−copyToPtr :: Utf8 -> Int -> Ptr a -> Int -> ST RealWorld ()
748+copyToPtr :: Utf8 l t -> Int -> Ptr a -> Int -> IO ()
335copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
749copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
336− ST $ \s ->
750+ IO $ \s ->
337 case copyByteArrayToAddr# ba# offset# mba# len# s of
751 case copyByteArrayToAddr# ba# offset# mba# len# s of
338 s -> (# s, () #)
752 s -> (# s, () #)
339
753
340
754
755+{-# INLINE writeWord8 #-}
341writeWord8 :: MBA s -> Int -> Word8 -> ST s ()
756writeWord8 :: MBA s -> Int -> Word8 -> ST s ()
342−writeWord8 (MBA# mba#) (I# i#) (W8# w#) =
757+writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
343 ST $ \s ->
758 ST $ \s ->
344− case writeWord8Array# mba# i# w# s of
759+ case writeWord8Array# mba# offset# w# s of
345 s -> (# s, () #)
760 s -> (# s, () #)