@@ -1,22 +1,45 @@
11{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
33module Data.Utf8
4− ( Utf8(..)
5− , toString
4+ ( String
5+ , Utf8(..)
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
624 , toBuilder
25+ , fromPtr
726 , fromChunks
827 , Chunk(..)
928 )
1029 where
1130
1231
13−import Data.Binary (Binary(..), Get)
32+import Prelude hiding (String, all, any, concat)
33+import Data.Binary (Binary(..), Get, getWord8, putWord8)
1434import Data.Binary.Put (putBuilder)
1535import Data.Binary.Get.Internal (readN)
1636import Data.Bits ((.&.), shiftR)
1737import qualified Data.ByteString.Internal as B
1838import qualified Data.ByteString.Builder.Internal as B
19−import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
39+import qualified Data.Char as Char
40+import qualified Data.List as List
41+import Data.String (IsString(..))
42+import Foreign.ForeignPtr (touchForeignPtr)
2043import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
2144import Foreign.Ptr (minusPtr, plusPtr)
2245import GHC.Exts
@@ -24,30 +47,261 @@ import GHC.Exts
2447 , RealWorld
2548 , ByteArray#, MutableByteArray#
2649 , isTrue#
27− , newByteArray#, unsafeFreezeByteArray#
50+ , newByteArray#
51+ , unsafeFreezeByteArray#
2852 , sizeofByteArray#
29− , copyAddrToByteArray#, copyByteArrayToAddr#
53+ , copyByteArray#
54+ , copyAddrToByteArray#
55+ , copyByteArrayToAddr#
3056 , writeWord8Array#,
3157 )
3258import GHC.IO
3359import GHC.ST (ST(ST), runST)
3460import GHC.Prim
35−import GHC.Word (Word8(W8#))
61+import GHC.Word (Word8(W8#), Word16(W16#))
3662
3763
3864
3965-- UTF-8
4066
4167
42−data Utf8 =
68+data Utf8 size tipe =
4369 Utf8 ByteArray#
4470
4571
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+
46300
47301-- EQUAL
48302
49303
50−instance Eq Utf8 where
304+instance Eq (Utf8 l t) where
51305 (==) (Utf8 ba1#) (Utf8 ba2#) =
52306 let
53307 !len1# = sizeofByteArray# ba1#
@@ -62,7 +316,7 @@ instance Eq Utf8 where
62316-- COMPARE
63317
64318
65−instance Ord Utf8 where
319+instance Ord (Utf8 l t) where
66320 compare (Utf8 ba1#) (Utf8 ba2#) =
67321 let
68322 !len1# = sizeofByteArray# ba1#
@@ -79,63 +333,257 @@ instance Ord Utf8 where
79333
80334
81335
82−-- BINARY
336+-- TO WORD16
83337
84338
85−instance Binary Utf8 where
86− put utf8@(Utf8 ba#) =
87− put (I# (sizeofByteArray# ba#)) <> putBuilder (toBuilder utf8)
88− get =
89− get >>= getUtf8
339+toWord16 :: String -> Maybe Word16
340+toWord16 (Utf8 ba#) =
341+ let !len# = sizeofByteArray# ba# in
342+ if isTrue# (len# ==# 0#) then
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
90396
91397
92−{-# INLINE getUtf8 #-}
93−getUtf8 :: Int -> Get Utf8
94−getUtf8 n =
95− if n > 0 then
96− readN n (copyFromByteString n)
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+
445+{-# INLINE getWidth #-}
446+getWidth :: Char -> Int
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# =
467+ if isTrue# (offset# >=# len#) then
468+ []
97469 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# #)
99477
478+ !newOffset# = offset# +# width#
479+ in
480+ char : toCharsHelp ba# newOffset# len#
100481
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− )
111482
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#))
112493
113−{-# NOINLINE empty #-}
114−empty :: Utf8
115−empty =
116− runST (unsafeFreeze =<< newByteArray 0)
494+
495+{-# INLINE chr3 #-}
496+chr3 :: ByteArray# -> Int# -> Word# -> Char
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
117557
118558
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+ ))
119567
120−-- CHUNKS
568+
569+
570+-- FROM CHUNKS
121571
122572
123573data Chunk
124− = Slice Int Int -- TODO try UNPACK
574+ = Slice (Ptr Word8) Int
125575 | Escape Word8
126576 | CodePoint Int
127577
128578
129−fromChunks :: ForeignPtr Word8 -> [Chunk] -> Utf8
130−fromChunks fptr chunks =
131− unsafeDupablePerformIO
132− (
579+fromChunks :: [Chunk] -> Utf8 l t
580+fromChunks chunks =
581+ unsafeDupablePerformIO (stToIO (
133582 do let !len = sum (map chunkToWidth chunks)
134− mba <- stToIO (newByteArray len)
135− stToIO (writeChunks (unsafeForeignPtrToPtr fptr) mba 0 chunks)
136− touchForeignPtr fptr
137− stToIO (unsafeFreeze mba)
138− )
583+ mba <- newByteArray len
584+ writeChunks mba 0 chunks
585+ freeze mba
586+ ))
139587
140588
141589chunkToWidth :: Chunk -> Int
@@ -151,36 +599,36 @@ chunkToWidth chunk =
151599 if code < 0xFFFF then 6 else 12
152600
153601
154−writeChunks :: Ptr Word8 -> MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
155−writeChunks ptr mba offset chunks =
602+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
603+writeChunks mba offset chunks =
156604 case chunks of
157605 [] ->
158606 return ()
159607
160608 chunk : chunks ->
161609 case chunk of
162− Slice off len ->
163− do copyFromPtr (plusPtr ptr off) mba offset len
610+ Slice ptr len ->
611+ do copyFromPtr ptr mba offset len
164612 let !newOffset = offset + len
165− writeChunks ptr mba newOffset chunks
613+ writeChunks mba newOffset chunks
166614
167615 Escape word ->
168616 do writeWord8 mba offset 0x5C {- \ -}
169617 writeWord8 mba (offset + 1) word
170618 let !newOffset = offset + 2
171− writeChunks ptr mba newOffset chunks
619+ writeChunks mba newOffset chunks
172620
173621 CodePoint code ->
174622 if code < 0xFFFF then
175623 do writeCode mba offset code
176624 let !newOffset = offset + 6
177− writeChunks ptr mba newOffset chunks
625+ writeChunks mba newOffset chunks
178626 else
179627 do let (hi,lo) = divMod (code - 0x10000) 0x400
180628 writeCode mba (offset ) (hi + 0xD800)
181629 writeCode mba (offset + 6) (lo + 0xDC00)
182630 let !newOffset = offset + 12
183− writeChunks ptr mba newOffset chunks
631+ writeChunks mba newOffset chunks
184632
185633
186634-- TODO see if it is faster to writeWord32 a block of hex-as-ascii
@@ -201,105 +649,64 @@ writeHex mba !offset !bits =
201649
202650
203651
204−-- TO BUILDER
652+-- UNDER 256 BINARY
205653
206654
207−{-# INLINE toBuilder #-}
208−toBuilder :: Utf8 -> B.Builder
209−toBuilder =
210− \utf8 -> B.builder (toBuilderHelp utf8)
655+instance Binary (Utf8 UNDER_256 t) where
656+ put bytes@(Utf8 ba#) =
657+ do putWord8 (W8# (int2Word# (sizeofByteArray# ba#)))
658+ putBuilder (toBuilder bytes)
659+ get =
660+ getUnder256 =<< getWord8
211661
212662
213−{-# INLINE toBuilderHelp #-}
214−toBuilderHelp :: Utf8 -> B.BuildStep a -> B.BuildStep a
215−toBuilderHelp !utf8@(Utf8 ba#) k =
216− go 0 (I# (sizeofByteArray# ba#))
217− where
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)
663+{-# INLINE getUnder256 #-}
664+getUnder256 :: Word8 -> Get (Utf8 UNDER_256 t)
665+getUnder256 w =
666+ let !n = fromIntegral w in
667+ readN n (copyFromByteString n)
231668
232669
233670
234−-- TO STRING
671+-- VERY LONG BINARY
235672
236673
237−toString :: Utf8 -> String
238−toString (Utf8 ba#) =
239− let
240− !len# = sizeofByteArray# ba#
241− in
242− toStringHelp ba# 0# len#
674+instance Binary (Utf8 VERY_LONG t) where
675+ put str =
676+ do put (size str)
677+ putBuilder (toBuilder str)
678+ get =
679+ getVeryLong =<< get
243680
244681
245−toStringHelp :: ByteArray# -> Int# -> Int# -> String
246−toStringHelp ba# offset# len# =
247− if isTrue# (offset# >=# len#) then
248− []
249− else
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# #)
682+{-# INLINE getVeryLong #-}
683+getVeryLong :: Int -> Get (Utf8 VERY_LONG t)
684+getVeryLong n =
685+ if n > 0
686+ then readN n (copyFromByteString n)
687+ else return empty
257688
258− !newOffset# = offset# +# width#
259− in
260− char : toStringHelp ba# newOffset# len#
261689
690+{-# NOINLINE empty #-}
691+empty :: Utf8 l t
692+empty =
693+ runST (freeze =<< newByteArray 0)
262694
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#))
273695
274696
275−{-# INLINE chr3 #-}
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#))
697+-- COPY FROM BYTESTRING
287698
288699
289−{-# INLINE chr4 #-}
290−chr4 :: ByteArray# -> Int# -> Word# -> Char
291−chr4 ba# offset# firstWord# =
292− let
293− !i1# = word2Int# firstWord#
294− !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))
295− !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#))
296− !i4# = word2Int# (indexWord8Array# ba# (offset# +# 3#))
297− !c1# = uncheckedIShiftL# (i1# -# 0xF0#) 18#
298− !c2# = uncheckedIShiftL# (i2# -# 0x80#) 12#
299− !c3# = uncheckedIShiftL# (i3# -# 0x80#) 6#
300− !c4# = i4# -# 0x80#
301− in
302− C# (chr# (c1# +# c2# +# c3# +# c4#))
700+{-# INLINE copyFromByteString #-}
701+copyFromByteString :: Int -> B.ByteString -> Utf8 l t
702+copyFromByteString len (B.PS fptr offset _) =
703+ unsafeDupablePerformIO
704+ (
705+ do mba <- stToIO (newByteArray len)
706+ stToIO (copyFromPtr (unsafeForeignPtrToPtr fptr `plusPtr` offset) mba 0 len)
707+ touchForeignPtr fptr
708+ stToIO (freeze mba)
709+ )
303710
304711
305712
@@ -310,36 +717,44 @@ data MBA s =
310717 MBA# (MutableByteArray# s)
311718
312719
313−newByteArray :: Int -> ST s (MBA s)
720+newByteArray :: Int -> ST s (MBA s) -- TODO see if newPinnedByteArray for len > 256 is positive
314721newByteArray (I# len#) =
315722 ST $ \s ->
316723 case newByteArray# len# s of
317724 (# s, mba# #) -> (# s, MBA# mba# #)
318725
319726
320−unsafeFreeze :: MBA s -> ST s Utf8
321−unsafeFreeze (MBA# mba#) =
727+freeze :: MBA s -> ST s (Utf8 l t)
728+freeze (MBA# mba#) =
322729 ST $ \s ->
323730 case unsafeFreezeByteArray# mba# s of
324731 (# s, ba# #) -> (# s, Utf8 ba# #)
325732
326733
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+
327741copyFromPtr :: 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#) =
329743 ST $ \s ->
330− case copyAddrToByteArray# src# mba# dst_off# len# s of
744+ case copyAddrToByteArray# src# mba# offset# len# s of
331745 s -> (# s, () #)
332746
333747
334−copyToPtr :: Utf8 -> Int -> Ptr a -> Int -> ST RealWorld ()
748+copyToPtr :: Utf8 l t -> Int -> Ptr a -> Int -> IO ()
335749copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
336− ST $ \s ->
750+ IO $ \s ->
337751 case copyByteArrayToAddr# ba# offset# mba# len# s of
338752 s -> (# s, () #)
339753
340754
755+{-# INLINE writeWord8 #-}
341756writeWord8 :: MBA s -> Int -> Word8 -> ST s ()
342−writeWord8 (MBA# mba#) (I# i#) (W8# w#) =
757+writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
343758 ST $ \s ->
344− case writeWord8Array# mba# i# w# s of
759+ case writeWord8Array# mba# offset# w# s of
345760 s -> (# s, () #)