@@ -0,0 +1,312 @@
1+{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}
2+
3+-----------------------------------------------------------------------------
4+-- |
5+-- Module : Data.Text.Lazy.Builder.Internal
6+-- Copyright : (c) 2010 Johan Tibell
7+-- License : BSD3-style (see LICENSE)
8+--
9+-- Maintainer : Johan Tibell <johan.tibell@gmail.com>
10+-- Stability : experimental
11+-- Portability : portable to Hugs and GHC
12+--
13+-- Efficient construction of lazy @Text@ values. The principal
14+-- operations on a @Builder@ are @singleton@, @fromText@, and
15+-- @fromLazyText@, which construct new builders, and 'mappend', which
16+-- concatenates two builders.
17+--
18+-- To get maximum performance when building lazy @Text@ values using a builder, associate @mappend@ calls to the right. For example, prefer
19+--
20+-- > singleton 'a' `mappend` (singleton 'b' `mappend` singleton 'c')
21+--
22+-- to
23+--
24+-- > singleton 'a' `mappend` singleton 'b' `mappend` singleton 'c'
25+--
26+-- as the latter associates @mappend@ to the left.
27+--
28+-----------------------------------------------------------------------------
29+
30+module Data.Text.Lazy.Builder.Internal
31+ ( -- * The Builder type
32+ Builder
33+ , toLazyText
34+ , toLazyTextWith
35+
36+ -- * Constructing Builders
37+ , singleton
38+ , fromText
39+ , fromLazyText
40+ , fromString
41+
42+ -- * Flushing the buffer state
43+ , flush
44+ ) where
45+
46+import Control.Monad.ST (ST, runST)
47+import Data.Bits ((.&.))
48+import Data.Monoid (Monoid(..))
49+import Data.Text.Internal (Text(..))
50+import Data.Text.Lazy.Internal (smallChunkSize)
51+import Data.Text.Unsafe (inlineInterleaveST)
52+import Data.Text.UnsafeChar (ord, unsafeWrite)
53+import Data.Text.UnsafeShift (shiftR)
54+import Prelude hiding (map, putChar)
55+
56+import qualified Data.String as String
57+import qualified Data.Text as S
58+import qualified Data.Text.Array as A
59+import qualified Data.Text.Lazy as L
60+
61+------------------------------------------------------------------------
62+
63+-- | A @Builder@ is an efficient way to build lazy @Text@ values.
64+-- There are several functions for constructing builders, but only one
65+-- to inspect them: to extract any data, you have to turn them into
66+-- lazy @Text@ values using @toLazyText@.
67+--
68+-- Internally, a builder constructs a lazy @Text@ by filling arrays
69+-- piece by piece. As each buffer is filled, it is \'popped\' off, to
70+-- become a new chunk of the resulting lazy @Text@. All this is
71+-- hidden from the user of the @Builder@.
72+newtype Builder = Builder {
73+ -- Invariant (from Data.Text.Lazy):
74+ -- The lists include no null Texts.
75+ runBuilder :: forall s. (Buffer s -> ST s [S.Text])
76+ -> Buffer s
77+ -> ST s [S.Text]
78+ }
79+
80+instance Monoid Builder where
81+ mempty = empty
82+ {-# INLINE mempty #-}
83+ mappend = append
84+ {-# INLINE mappend #-}
85+ mconcat = foldr mappend mempty
86+ {-# INLINE mconcat #-}
87+
88+instance String.IsString Builder where
89+ fromString = fromString
90+ {-# INLINE fromString #-}
91+
92+instance Show Builder where
93+ show = show . toLazyText
94+
95+instance Eq Builder where
96+ a == b = toLazyText a == toLazyText b
97+
98+instance Ord Builder where
99+ a <= b = toLazyText a <= toLazyText b
100+
101+------------------------------------------------------------------------
102+
103+-- | /O(1)./ The empty @Builder@, satisfying
104+--
105+-- * @'toLazyText' 'empty' = 'L.empty'@
106+--
107+empty :: Builder
108+empty = Builder (\ k buf -> k buf)
109+{-# INLINE empty #-}
110+
111+-- | /O(1)./ A @Builder@ taking a single character, satisfying
112+--
113+-- * @'toLazyText' ('singleton' c) = 'L.singleton' c@
114+--
115+singleton :: Char -> Builder
116+singleton c = writeAtMost 2 $ \ marr o ->
117+ if n < 0x10000
118+ then A.unsafeWrite marr o (fromIntegral n) >> return 1
119+ else do
120+ A.unsafeWrite marr o lo
121+ A.unsafeWrite marr (o+1) hi
122+ return 2
123+ where n = ord c
124+ m = n - 0x10000
125+ lo = fromIntegral $ (m `shiftR` 10) + 0xD800
126+ hi = fromIntegral $ (m .&. 0x3FF) + 0xDC00
127+{-# INLINE singleton #-}
128+
129+------------------------------------------------------------------------
130+
131+-- | /O(1)./ The concatenation of two builders, an associative
132+-- operation with identity 'empty', satisfying
133+--
134+-- * @'toLazyText' ('append' x y) = 'L.append' ('toLazyText' x) ('toLazyText' y)@
135+--
136+append :: Builder -> Builder -> Builder
137+append (Builder f) (Builder g) = Builder (f . g)
138+{-# INLINE [0] append #-}
139+
140+-- TODO: Experiment to find the right threshold.
141+copyLimit :: Int
142+copyLimit = 128
143+
144+-- This function attempts to merge small @Text@ values instead of
145+-- treating each value as its own chunk. We may not always want this.
146+
147+-- | /O(1)./ A @Builder@ taking a 'S.Text', satisfying
148+--
149+-- * @'toLazyText' ('fromText' t) = 'L.fromChunks' [t]@
150+--
151+fromText :: S.Text -> Builder
152+fromText t@(Text arr off l)
153+ | S.null t = empty
154+ | l <= copyLimit = writeN l $ \marr o -> A.copyI marr o arr off (l+o)
155+ | otherwise = flush `append` mapBuilder (t :)
156+{-# INLINE [1] fromText #-}
157+
158+{-# RULES
159+"fromText/pack" forall s .
160+ fromText (S.pack s) = fromString s
161+ #-}
162+
163+-- | /O(1)./ A Builder taking a @String@, satisfying
164+--
165+-- * @'toLazyText' ('fromString' s) = 'L.fromChunks' [S.pack s]@
166+--
167+fromString :: String -> Builder
168+fromString str = Builder $ \k (Buffer p0 o0 u0 l0) ->
169+ let loop !marr !o !u !l [] = k (Buffer marr o u l)
170+ loop marr o u l s@(c:cs)
171+ | l <= 1 = do
172+ arr <- A.unsafeFreeze marr
173+ let !t = Text arr o u
174+ marr' <- A.new chunkSize
175+ ts <- inlineInterleaveST (loop marr' 0 0 chunkSize s)
176+ return $ t : ts
177+ | otherwise = do
178+ n <- unsafeWrite marr (o+u) c
179+ loop marr o (u+n) (l-n) cs
180+ in loop p0 o0 u0 l0 str
181+ where
182+ chunkSize = smallChunkSize
183+{-# INLINE fromString #-}
184+
185+-- | /O(1)./ A @Builder@ taking a lazy @Text@, satisfying
186+--
187+-- * @'toLazyText' ('fromLazyText' t) = t@
188+--
189+fromLazyText :: L.Text -> Builder
190+fromLazyText ts = flush `append` mapBuilder (L.toChunks ts ++)
191+{-# INLINE fromLazyText #-}
192+
193+------------------------------------------------------------------------
194+
195+-- Our internal buffer type
196+data Buffer s = Buffer {-# UNPACK #-} !(A.MArray s)
197+ {-# UNPACK #-} !Int -- offset
198+ {-# UNPACK #-} !Int -- used units
199+ {-# UNPACK #-} !Int -- length left
200+
201+------------------------------------------------------------------------
202+
203+-- | /O(n)./ Extract a lazy @Text@ from a @Builder@ with a default
204+-- buffer size. The construction work takes place if and when the
205+-- relevant part of the lazy @Text@ is demanded.
206+toLazyText :: Builder -> L.Text
207+toLazyText = toLazyTextWith smallChunkSize
208+
209+-- | /O(n)./ Extract a lazy @Text@ from a @Builder@, using the given
210+-- size for the initial buffer. The construction work takes place if
211+-- and when the relevant part of the lazy @Text@ is demanded.
212+--
213+-- If the initial buffer is too small to hold all data, subsequent
214+-- buffers will be the default buffer size.
215+toLazyTextWith :: Int -> Builder -> L.Text
216+toLazyTextWith chunkSize m = L.fromChunks (runST $
217+ newBuffer chunkSize >>= runBuilder (m `append` flush) (const (return [])))
218+
219+-- | /O(1)./ Pop the strict @Text@ we have constructed so far, if any,
220+-- yielding a new chunk in the result lazy @Text@.
221+flush :: Builder
222+flush = Builder $ \ k buf@(Buffer p o u l) ->
223+ if u == 0
224+ then k buf
225+ else do arr <- A.unsafeFreeze p
226+ let !b = Buffer p (o+u) 0 l
227+ !t = Text arr o u
228+ ts <- inlineInterleaveST (k b)
229+ return $! t : ts
230+
231+------------------------------------------------------------------------
232+
233+-- | Sequence an ST operation on the buffer
234+withBuffer :: (forall s. Buffer s -> ST s (Buffer s)) -> Builder
235+withBuffer f = Builder $ \k buf -> f buf >>= k
236+{-# INLINE withBuffer #-}
237+
238+-- | Get the size of the buffer
239+withSize :: (Int -> Builder) -> Builder
240+withSize f = Builder $ \ k buf@(Buffer _ _ _ l) ->
241+ runBuilder (f l) k buf
242+{-# INLINE withSize #-}
243+
244+-- | Map the resulting list of texts.
245+mapBuilder :: ([S.Text] -> [S.Text]) -> Builder
246+mapBuilder f = Builder (fmap f .)
247+
248+------------------------------------------------------------------------
249+
250+-- | Ensure that there are at least @n@ many elements available.
251+ensureFree :: Int -> Builder
252+ensureFree !n = withSize $ \ l ->
253+ if n <= l
254+ then empty
255+ else flush `append'` withBuffer (const (newBuffer (max n smallChunkSize)))
256+{-# INLINE [0] ensureFree #-}
257+
258+writeAtMost :: Int -> (forall s. A.MArray s -> Int -> ST s Int) -> Builder
259+writeAtMost n f = ensureFree n `append'` withBuffer (writeBuffer f)
260+{-# INLINE [0] writeAtMost #-}
261+
262+-- | Ensure that @n@ many elements are available, and then use @f@ to
263+-- write some elements into the memory.
264+writeN :: Int -> (forall s. A.MArray s -> Int -> ST s ()) -> Builder
265+writeN n f = writeAtMost n (\ p o -> f p o >> return n)
266+{-# INLINE writeN #-}
267+
268+writeBuffer :: (A.MArray s -> Int -> ST s Int) -> Buffer s -> ST s (Buffer s)
269+writeBuffer f (Buffer p o u l) = do
270+ n <- f p (o+u)
271+ return $! Buffer p o (u+n) (l-n)
272+{-# INLINE writeBuffer #-}
273+
274+newBuffer :: Int -> ST s (Buffer s)
275+newBuffer size = do
276+ arr <- A.new size
277+ return $! Buffer arr 0 0 size
278+{-# INLINE newBuffer #-}
279+
280+------------------------------------------------------------------------
281+-- Some nice rules for Builder
282+
283+-- This function makes GHC understand that 'writeN' and 'ensureFree'
284+-- are *not* recursive in the precense of the rewrite rules below.
285+-- This is not needed with GHC 7+.
286+append' :: Builder -> Builder -> Builder
287+append' (Builder f) (Builder g) = Builder (f . g)
288+{-# INLINE append' #-}
289+
290+{-# RULES
291+
292+"append/writeAtMost" forall a b (f::forall s. A.MArray s -> Int -> ST s Int)
293+ (g::forall s. A.MArray s -> Int -> ST s Int) ws.
294+ append (writeAtMost a f) (append (writeAtMost b g) ws) =
295+ append (writeAtMost (a+b) (\marr o -> f marr o >>= \ n ->
296+ g marr (o+n) >>= \ m ->
297+ let s = n+m in s `seq` return s)) ws
298+
299+"writeAtMost/writeAtMost" forall a b (f::forall s. A.MArray s -> Int -> ST s Int)
300+ (g::forall s. A.MArray s -> Int -> ST s Int).
301+ append (writeAtMost a f) (writeAtMost b g) =
302+ writeAtMost (a+b) (\marr o -> f marr o >>= \ n ->
303+ g marr (o+n) >>= \ m ->
304+ let s = n+m in s `seq` return s)
305+
306+"ensureFree/ensureFree" forall a b .
307+ append (ensureFree a) (ensureFree b) = ensureFree (max a b)
308+
309+"flush/flush"
310+ append flush flush = flush
311+
312+ #-}