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