git.iko.soy/elk
on f4401ac help sign in
elk/compiler/src/Data/Utf8.hs
616 lines 15 kB history raw
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}
3module Data.Utf8
4 ( Utf8(..)
5 , isEmpty
6 , empty
7 , size
8 , contains
9 , startsWith
10 , startsWithChar
11 , endsWithWord8
12 , split
13 , join
14 --
15 , getUnder256
16 , putUnder256
17 --
18 , getVeryLong
19 , putVeryLong
20 --
21 , toChars
22 , toBuilder
23 , toEscapedBuilder
24 --
25 , fromPtr
26 , fromSnippet
27 , fromChars
28 --
29 , MBA
30 , newByteArray
31 , copyFromPtr
32 , writeWord8
33 , freeze
34 )
35 where
38import Prelude hiding (String, all, any, concat)
39import Data.Binary (Get, get, getWord8, Put, put, putWord8)
40import Data.Binary.Put (putBuilder)
41import Data.Binary.Get.Internal (readN)
42import Data.Bits ((.&.), shiftR)
43import qualified Data.ByteString.Internal as B
44import qualified Data.ByteString.Builder.Internal as B
45import qualified Data.Char as Char
46import qualified Data.List as List
47import Foreign.ForeignPtr (touchForeignPtr)
48import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
49import Foreign.Ptr (minusPtr, plusPtr)
50import GHC.Exts
51 ( Int(I#), Ptr(Ptr), Char(C#)
52 , RealWorld
53 , ByteArray#, MutableByteArray#
54 , isTrue#
55 , newByteArray#
56 , unsafeFreezeByteArray#
57 , sizeofByteArray#
58 , copyByteArray#
59 , copyAddrToByteArray#
60 , copyByteArrayToAddr#
61 , writeWord8Array#
62 )
63import GHC.IO
64import GHC.ST (ST(ST), runST)
65import GHC.Prim
66import GHC.Word (Word8(W8#))
68import qualified Parse.Primitives as P
72-- UTF-8
75data Utf8 tipe =
76 Utf8 ByteArray#
80-- EMPTY
83{-# NOINLINE empty #-}
84empty :: Utf8 t
85empty =
86 runST (freeze =<< newByteArray 0)
89isEmpty :: Utf8 t -> Bool
90isEmpty (Utf8 ba#) =
91 isTrue# (sizeofByteArray# ba# ==# 0#)
95-- SIZE
98size :: Utf8 t -> Int
99size (Utf8 ba#) =
100 I# (sizeofByteArray# ba#)
104-- CONTAINS
107contains :: Word8 -> Utf8 t -> Bool
108contains (W8# word#) (Utf8 ba#) =
109 containsHelp word# ba# 0# (sizeofByteArray# ba#)
112containsHelp :: Word# -> ByteArray# -> Int# -> Int# -> Bool
113containsHelp word# ba# !offset# len# =
114 if isTrue# (offset# <# len#) then
115 if isTrue# (eqWord# word# (indexWord8Array# ba# offset#))
116 then True
117 else containsHelp word# ba# (offset# +# 1#) len#
118 else
119 False
123-- STARTS WITH
126{-# INLINE startsWith #-}
127startsWith :: Utf8 t -> Utf8 t -> Bool
128startsWith (Utf8 ba1#) (Utf8 ba2#) =
129 let
130 !len1# = sizeofByteArray# ba1#
131 !len2# = sizeofByteArray# ba2#
132 in
133 isTrue# (len1# <=# len2#)
134 &&
135 isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#)
139-- STARTS WITH CHAR
142startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool
143startsWithChar isGood bytes@(Utf8 ba#) =
144 if isEmpty bytes then
145 False
146 else
147 let
148 !w# = indexWord8Array# ba# 0#
149 !char
150 | isTrue# (ltWord# w# 0xC0##) = C# (chr# (word2Int# w#))
151 | isTrue# (ltWord# w# 0xE0##) = chr2 ba# 0# w#
152 | isTrue# (ltWord# w# 0xF0##) = chr3 ba# 0# w#
153 | True = chr4 ba# 0# w#
154 in
155 isGood char
159-- ENDS WITH WORD
162endsWithWord8 :: Word8 -> Utf8 t -> Bool
163endsWithWord8 (W8# w#) (Utf8 ba#) =
164 let len# = sizeofByteArray# ba# in
165 isTrue# (len# ># 0#)
166 &&
167 isTrue# (eqWord# w# (indexWord8Array# ba# (len# -# 1#)))
171-- SPLIT
174split :: Word8 -> Utf8 t -> [Utf8 t]
175split (W8# divider#) str@(Utf8 ba#) =
176 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])
179splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t]
180splitHelp str start offsets =
181 case offsets of
182 [] ->
183 [ unsafeSlice str start (size str) ]
185 offset : offsets ->
186 unsafeSlice str start offset : splitHelp str (offset + 1) offsets
189findDividers :: Word# -> ByteArray# -> Int# -> Int# -> [Int] -> [Int]
190findDividers divider# ba# !offset# len# revOffsets =
191 if isTrue# (offset# <# len#) then
192 findDividers divider# ba# (offset# +# 1#) len# $
193 if isTrue# (eqWord# divider# (indexWord8Array# ba# offset#))
194 then I# offset# : revOffsets
195 else revOffsets
196 else
197 reverse revOffsets
200unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t
201unsafeSlice str start end =
202 let !len = end - start in
203 if len == 0 then
204 empty
205 else
206 runST $
207 do mba <- newByteArray len
208 copy str start mba 0 len
209 freeze mba
213-- JOIN
216join :: Word8 -> [Utf8 t] -> Utf8 t
217join sep strings =
218 case strings of
219 [] ->
220 empty
222 str:strs ->
223 runST $
224 do let !len = List.foldl' (\w s -> w + 1 + size s) (size str) strs
225 mba <- newByteArray len
226 joinHelp sep mba 0 str strs
227 freeze mba
230joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s ()
231joinHelp sep mba offset str strings =
232 let
233 !len = size str
234 in
235 case strings of
236 [] ->
237 copy str 0 mba offset len
239 s:ss ->
240 do copy str 0 mba offset len
241 let !dotOffset = offset + len
242 writeWord8 mba dotOffset sep
243 let !newOffset = dotOffset + 1
244 joinHelp sep mba newOffset s ss
248-- EQUAL
251instance Eq (Utf8 t) where
252 (==) (Utf8 ba1#) (Utf8 ba2#) =
253 let
254 !len1# = sizeofByteArray# ba1#
255 !len2# = sizeofByteArray# ba2#
256 in
257 isTrue# (len1# ==# len2#)
258 &&
259 isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#)
263-- COMPARE
266instance Ord (Utf8 t) where
267 compare (Utf8 ba1#) (Utf8 ba2#) =
268 let
269 !len1# = sizeofByteArray# ba1#
270 !len2# = sizeofByteArray# ba2#
271 !len# = if isTrue# (len1# <# len2#) then len1# else len2#
272 !cmp# = compareByteArrays# ba1# 0# ba2# 0# len#
273 in
274 case () of
275 _ | isTrue# (cmp# <# 0#) -> LT
276 | isTrue# (cmp# ># 0#) -> GT
277 | isTrue# (len1# <# len2#) -> LT
278 | isTrue# (len1# ># len2#) -> GT
279 | True -> EQ
283-- FROM STRING
286fromChars :: [Char] -> Utf8 t
287fromChars chars =
288 runST
289 (
290 do mba <- newByteArray (sum (map getWidth chars))
291 writeChars mba 0 chars
292 )
295writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t)
296writeChars !mba !offset chars =
297 case chars of
298 [] ->
299 freeze mba
301 char : chars
302 | n < 0x80 ->
303 do writeWord8 mba (offset ) (fromIntegral n)
304 writeChars mba (offset + 1) chars
306 | n < 0x800 ->
307 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))
308 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))
309 writeChars mba (offset + 2) chars
311 | n < 0x10000 ->
312 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))
313 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
314 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))
315 writeChars mba (offset + 3) chars
317 | otherwise ->
318 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))
319 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))
320 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
321 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))
322 writeChars mba (offset + 4) chars
324 where
325 n = Char.ord char
328{-# INLINE getWidth #-}
329getWidth :: Char -> Int
330getWidth char
331 | code < 0x80 = 1
332 | code < 0x800 = 2
333 | code < 0x10000 = 3
334 | otherwise = 4
335 where
336 code = Char.ord char
340-- TO CHARS
343toChars :: Utf8 t -> [Char]
344toChars (Utf8 ba#) =
345 toCharsHelp ba# 0# (sizeofByteArray# ba#)
348toCharsHelp :: ByteArray# -> Int# -> Int# -> [Char]
349toCharsHelp ba# offset# len# =
350 if isTrue# (offset# >=# len#) then
351 []
352 else
353 let
354 !w# = indexWord8Array# ba# offset#
355 !(# char, width# #)
356 | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #)
357 | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #)
358 | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #)
359 | True = (# chr4 ba# offset# w#, 4# #)
361 !newOffset# = offset# +# width#
362 in
363 char : toCharsHelp ba# newOffset# len#
366{-# INLINE chr2 #-}
367chr2 :: ByteArray# -> Int# -> Word# -> Char
368chr2 ba# offset# firstWord# =
369 let
370 !i1# = word2Int# firstWord#
371 !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))
372 !c1# = uncheckedIShiftL# (i1# -# 0xC0#) 6#
373 !c2# = i2# -# 0x80#
374 in
375 C# (chr# (c1# +# c2#))
378{-# INLINE chr3 #-}
379chr3 :: ByteArray# -> Int# -> Word# -> Char
380chr3 ba# offset# firstWord# =
381 let
382 !i1# = word2Int# firstWord#
383 !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))
384 !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#))
385 !c1# = uncheckedIShiftL# (i1# -# 0xE0#) 12#
386 !c2# = uncheckedIShiftL# (i2# -# 0x80#) 6#
387 !c3# = i3# -# 0x80#
388 in
389 C# (chr# (c1# +# c2# +# c3#))
392{-# INLINE chr4 #-}
393chr4 :: ByteArray# -> Int# -> Word# -> Char
394chr4 ba# offset# firstWord# =
395 let
396 !i1# = word2Int# firstWord#
397 !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))
398 !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#))
399 !i4# = word2Int# (indexWord8Array# ba# (offset# +# 3#))
400 !c1# = uncheckedIShiftL# (i1# -# 0xF0#) 18#
401 !c2# = uncheckedIShiftL# (i2# -# 0x80#) 12#
402 !c3# = uncheckedIShiftL# (i3# -# 0x80#) 6#
403 !c4# = i4# -# 0x80#
404 in
405 C# (chr# (c1# +# c2# +# c3# +# c4#))
409-- TO BUILDER
412{-# INLINE toBuilder #-}
413toBuilder :: Utf8 t -> B.Builder
414toBuilder =
415 \bytes -> B.builder (toBuilderHelp bytes)
418{-# INLINE toBuilderHelp #-}
419toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a
420toBuilderHelp !bytes@(Utf8 ba#) k =
421 go 0 (I# (sizeofByteArray# ba#))
422 where
423 go !offset !end !(B.BufferRange bOffset bEnd) =
424 let
425 !bLen = minusPtr bEnd bOffset
426 !len = end - offset
427 in
428 if len <= bLen then
429 do copyToPtr bytes offset bOffset len
430 let !br' = B.BufferRange (plusPtr bOffset len) bEnd
431 k br'
432 else
433 do copyToPtr bytes offset bOffset bLen
434 let !offset' = offset + bLen
435 return $ B.bufferFull 1 bEnd (go offset' end)
439-- TO ESCAPED BUILDER
442{-# INLINE toEscapedBuilder #-}
443toEscapedBuilder :: Word8 -> Word8 -> Utf8 t -> B.Builder
444toEscapedBuilder before after =
445 \name -> B.builder (toEscapedBuilderHelp before after name)
448{-# INLINE toEscapedBuilderHelp #-}
449toEscapedBuilderHelp :: Word8 -> Word8 -> Utf8 t -> B.BuildStep a -> B.BuildStep a
450toEscapedBuilderHelp before after !name@(Utf8 ba#) k =
451 go 0 (I# (sizeofByteArray# ba#))
452 where
453 go !offset !len !(B.BufferRange bOffset bEnd) =
454 let
455 !bLen = minusPtr bEnd bOffset
456 in
457 if len <= bLen then
458 do -- TODO test if writing word-by-word is faster
459 copyToPtr name offset bOffset len
460 escape before after bOffset name offset len 0
461 let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
462 k newBufferRange
463 else
464 do copyToPtr name offset bOffset bLen
465 escape before after bOffset name offset bLen 0
466 let !newOffset = offset + bLen
467 let !newLength = len - bLen
468 return $ B.bufferFull 1 bEnd (go newOffset newLength)
471escape :: Word8 -> Word8 -> Ptr a -> Utf8 t -> Int -> Int -> Int -> IO ()
472escape before@(W8# before#) after ptr name@(Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =
473 if isTrue# (i# <# len#) then
474 if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))
475 then
476 do writeWordToPtr ptr i after
477 escape before after ptr name offset len (i + 1)
478 else
479 do escape before after ptr name offset len (i + 1)
481 else
482 return ()
486-- FROM PTR
489fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t
490fromPtr pos end =
491 unsafeDupablePerformIO (stToIO (
492 do let !len = minusPtr end pos
493 mba <- newByteArray len
494 copyFromPtr pos mba 0 len
495 freeze mba
496 ))
500-- FROM SNIPPET
503fromSnippet :: P.Snippet -> Utf8 t
504fromSnippet (P.Snippet fptr off len _ _) =
505 unsafeDupablePerformIO (stToIO (
506 do mba <- newByteArray len
507 let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off
508 copyFromPtr pos mba 0 len
509 freeze mba
510 ))
514-- BINARY
517putUnder256 :: Utf8 t -> Put
518putUnder256 bytes =
519 do putWord8 (fromIntegral (size bytes))
520 putBuilder (toBuilder bytes)
523getUnder256 :: Get (Utf8 t)
524getUnder256 =
525 do word <- getWord8
526 let !n = fromIntegral word
527 readN n (copyFromByteString n)
530putVeryLong :: Utf8 t -> Put
531putVeryLong bytes =
532 do put (size bytes)
533 putBuilder (toBuilder bytes)
536getVeryLong :: Get (Utf8 t)
537getVeryLong =
538 do n <- get
539 if n > 0
540 then readN n (copyFromByteString n)
541 else return empty
545-- COPY FROM BYTESTRING
548{-# INLINE copyFromByteString #-}
549copyFromByteString :: Int -> B.ByteString -> Utf8 t
550copyFromByteString len (B.PS fptr offset _) =
551 unsafeDupablePerformIO
552 (
553 do mba <- stToIO (newByteArray len)
554 stToIO (copyFromPtr (unsafeForeignPtrToPtr fptr `plusPtr` offset) mba 0 len)
555 touchForeignPtr fptr
556 stToIO (freeze mba)
557 )
561-- PRIMITIVES
564data MBA s =
565 MBA# (MutableByteArray# s)
568newByteArray :: Int -> ST s (MBA s) -- TODO see if newPinnedByteArray for len > 256 is positive
569newByteArray (I# len#) =
570 ST $ \s ->
571 case newByteArray# len# s of
572 (# s, mba# #) -> (# s, MBA# mba# #)
575freeze :: MBA s -> ST s (Utf8 t)
576freeze (MBA# mba#) =
577 ST $ \s ->
578 case unsafeFreezeByteArray# mba# s of
579 (# s, ba# #) -> (# s, Utf8 ba# #)
582copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s ()
583copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =
584 ST $ \s ->
585 case copyByteArray# ba# offset# mba# i# len# s of
586 s -> (# s, () #)
589copyFromPtr :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld ()
590copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =
591 ST $ \s ->
592 case copyAddrToByteArray# src# mba# offset# len# s of
593 s -> (# s, () #)
596copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO ()
597copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
598 IO $ \s ->
599 case copyByteArrayToAddr# ba# offset# mba# len# s of
600 s -> (# s, () #)
603{-# INLINE writeWord8 #-}
604writeWord8 :: MBA s -> Int -> Word8 -> ST s ()
605writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
606 ST $ \s ->
607 case writeWord8Array# mba# offset# w# s of
608 s -> (# s, () #)
611{-# INLINE writeWordToPtr #-}
612writeWordToPtr :: Ptr a -> Int -> Word8 -> IO ()
613writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =
614 IO $ \s ->
615 case writeWord8OffAddr# addr# offset# word# s of
616 s -> (# s, () #)