@@ -0,0 +1,215 @@
1+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}
3+module Data.Utf8
4+ ( Utf8
5+ , toBuilder
6+ , fromChunks
7+ , Chunk(..)
8+ )
9+ where
10+
11+
12+import Data.Bits ((.&.), shiftR)
13+import qualified Data.ByteString.Builder.Internal as B
14+import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
15+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
16+import Foreign.Ptr (minusPtr, plusPtr)
17+import GHC.Exts
18+ ( Int(I#), Ptr(Ptr)
19+ , RealWorld
20+ , ByteArray#, MutableByteArray#
21+ , isTrue#
22+ , newByteArray#, unsafeFreezeByteArray#
23+ , sizeofByteArray#
24+ , copyAddrToByteArray#, copyByteArrayToAddr#
25+ , writeWord8Array#, writeWord16Array#
26+ )
27+import GHC.IO
28+import GHC.ST (ST(ST))
29+import GHC.Prim
30+import GHC.Word (Word8(W8#), Word16(W16#))
31+
32+
33+
34+-- UTF-8
35+
36+
37+data Utf8 =
38+ Utf8 ByteArray#
39+
40+
41+
42+-- EQUAL
43+
44+
45+instance Eq Utf8 where
46+ (==) (Utf8 ba1#) (Utf8 ba2#) =
47+ let
48+ !len1# = sizeofByteArray# ba1#
49+ !len2# = sizeofByteArray# ba2#
50+ in
51+ isTrue# (len1# ==# len2#)
52+ &&
53+ isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#)
54+
55+
56+
57+-- CHUNKS
58+
59+
60+data Chunk
61+ = Slice Int Int -- TODO try UNPACK
62+ | Escape Word16
63+ | CodePoint Int
64+
65+
66+fromChunks :: ForeignPtr Word8 -> [Chunk] -> Utf8
67+fromChunks fptr chunks =
68+ unsafeDupablePerformIO
69+ (
70+ do let !len = sum (map chunkToWidth chunks)
71+ mba <- stToIO (newByteArray len)
72+ stToIO (writeChunks (unsafeForeignPtrToPtr fptr) mba 0 chunks)
73+ touchForeignPtr fptr
74+ stToIO (unsafeFreeze mba)
75+ )
76+
77+
78+chunkToWidth :: Chunk -> Int
79+chunkToWidth chunk =
80+ case chunk of
81+ Slice _ len ->
82+ len
83+
84+ Escape _ ->
85+ 2
86+
87+ CodePoint code ->
88+ if code < 0xFFFF then 6 else 12
89+
90+
91+writeChunks :: Ptr Word8 -> MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
92+writeChunks ptr mba offset chunks =
93+ case chunks of
94+ [] ->
95+ return ()
96+
97+ chunk : chunks ->
98+ case chunk of
99+ Slice off len ->
100+ do copyFromPtr (plusPtr ptr off) mba offset len
101+ let !newOffset = offset + len
102+ writeChunks ptr mba newOffset chunks
103+
104+ Escape word ->
105+ do writeWord16 mba offset word
106+ let !newOffset = offset + 2
107+ writeChunks ptr mba newOffset chunks
108+
109+ CodePoint code ->
110+ if code < 0xFFFF then
111+ do writeCode mba offset code
112+ let !newOffset = offset + 6
113+ writeChunks ptr mba newOffset chunks
114+ else
115+ do let (hi,lo) = divMod (code - 0x10000) 0x400
116+ writeCode mba (offset ) (hi + 0xD800)
117+ writeCode mba (offset + 6) (lo + 0xDC00)
118+ let !newOffset = offset + 12
119+ writeChunks ptr mba newOffset chunks
120+
121+
122+-- TODO see if it is faster to writeWord32 a block of hex-as-ascii
123+writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
124+writeCode mba offset code =
125+ do writeWord16 mba offset 0x5C75 {- \u -}
126+ writeHex mba (offset + 2) (shiftR code 12)
127+ writeHex mba (offset + 3) (shiftR code 8)
128+ writeHex mba (offset + 4) (shiftR code 4)
129+ writeHex mba (offset + 5) code
130+
131+
132+writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
133+writeHex mba !offset !bits =
134+ do let !n = fromIntegral bits .&. 0x0F
135+ writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)
136+
137+
138+
139+-- TO BUILDER
140+
141+
142+{-# INLINE toBuilder #-}
143+toBuilder :: Utf8 -> B.Builder
144+toBuilder =
145+ \utf8 -> B.builder (toBuilderHelp utf8)
146+
147+
148+{-# INLINE toBuilderHelp #-}
149+toBuilderHelp :: Utf8 -> B.BuildStep a -> B.BuildStep a
150+toBuilderHelp !utf8@(Utf8 ba#) k =
151+ go 0 (I# (sizeofByteArray# ba#))
152+ where
153+ go !offset !end !(B.BufferRange bOffset bEnd) =
154+ let
155+ !bLen = minusPtr bEnd bOffset
156+ !len = end - offset
157+ in
158+ if len <= bLen then
159+ do stToIO (copyToPtr utf8 offset bOffset len)
160+ let !br' = B.BufferRange (plusPtr bOffset len) bEnd
161+ k br'
162+ else
163+ do stToIO (copyToPtr utf8 offset bOffset bLen)
164+ let !offset' = offset + bLen
165+ return $ B.bufferFull 1 bEnd (go offset' end)
166+
167+
168+
169+-- PRIMITIVES
170+
171+
172+data MBA s =
173+ MBA# (MutableByteArray# s)
174+
175+
176+newByteArray :: Int -> ST s (MBA s)
177+newByteArray (I# len#) =
178+ ST $ \s ->
179+ case newByteArray# len# s of
180+ (# s, mba# #) -> (# s, MBA# mba# #)
181+
182+
183+unsafeFreeze :: MBA s -> ST s Utf8
184+unsafeFreeze (MBA# mba#) =
185+ ST $ \s ->
186+ case unsafeFreezeByteArray# mba# s of
187+ (# s, ba# #) -> (# s, Utf8 ba# #)
188+
189+
190+copyFromPtr :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld ()
191+copyFromPtr (Ptr src#) (MBA# mba#) (I# dst_off#) (I# len#) =
192+ ST $ \s ->
193+ case copyAddrToByteArray# src# mba# dst_off# len# s of
194+ s -> (# s, () #)
195+
196+
197+copyToPtr :: Utf8 -> Int -> Ptr a -> Int -> ST RealWorld ()
198+copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
199+ ST $ \s ->
200+ case copyByteArrayToAddr# ba# offset# mba# len# s of
201+ s -> (# s, () #)
202+
203+
204+writeWord8 :: MBA s -> Int -> Word8 -> ST s ()
205+writeWord8 (MBA# mba#) (I# i#) (W8# w#) =
206+ ST $ \s ->
207+ case writeWord8Array# mba# i# w# s of
208+ s -> (# s, () #)
209+
210+
211+writeWord16 :: MBA s -> Int -> Word16 -> ST s ()
212+writeWord16 (MBA# mba#) (I# i#) (W16# w#) =
213+ ST $ \s ->
214+ case writeWord16Array# mba# i# w# s of
215+ s -> (# s, () #)