{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}
{-# OPTIONS_HADDOCK not-home #-}
module Data.Text.Internal.Builder
(
Builder
, toLazyText
, toLazyTextWith
, singleton
, fromText
, fromLazyText
, fromString
, flush
, append'
, ensureFree
, writeN
) where
import Control.Monad.ST (ST, runST)
import Data.Monoid (Monoid(..))
#if MIN_VERSION_base(4,9,0)
import Data.Semigroup (Semigroup(..))
#endif
import Data.Text.Internal (Text(..))
import Data.Text.Internal.Lazy (smallChunkSize)
import Data.Text.Unsafe (inlineInterleaveST)
import Data.Text.Internal.Unsafe.Char (unsafeWrite)
import Prelude hiding (map, putChar)
import qualified Data.String as String
import qualified Data.Text as S
import qualified Data.Text.Array as A
import qualified Data.Text.Lazy as L
newtype Builder = Builder {
runBuilder :: forall s. (Buffer s -> ST s [S.Text])
-> Buffer s
-> ST s [S.Text]
}
#if MIN_VERSION_base(4,9,0)
instance Semigroup Builder where
(<>) = append
{-# INLINE (<>) #-}
#endif
instance Monoid Builder where
mempty = empty
{-# INLINE mempty #-}
#if MIN_VERSION_base(4,9,0)
mappend = (<>)
#else
mappend = append
#endif
{-# INLINE mappend #-}
mconcat = foldr mappend Data.Monoid.mempty
{-# INLINE mconcat #-}
instance String.IsString Builder where
fromString = fromString
{-# INLINE fromString #-}
instance Show Builder where
show = show . toLazyText
instance Eq Builder where
a == b = toLazyText a == toLazyText b
instance Ord Builder where
a <= b = toLazyText a <= toLazyText b
empty :: Builder
empty = Builder (\ k buf -> k buf)
{-# INLINE empty #-}
singleton :: Char -> Builder
singleton c = writeAtMost 2 $ \ marr o -> unsafeWrite marr o c
{-# INLINE singleton #-}
append :: Builder -> Builder -> Builder
append (Builder f) (Builder g) = Builder (f . g)
{-# INLINE [0] append #-}
copyLimit :: Int
copyLimit = 128
fromText :: S.Text -> Builder
fromText t@(Text arr off l)
| S.null t = empty
| l <= copyLimit = writeN l $ \marr o -> A.copyI marr o arr off (l+o)
| otherwise = flush `append` mapBuilder (t :)
{-# INLINE [1] fromText #-}
{-# RULES
"fromText/pack" forall s .
fromText (S.pack s) = fromString s
#-}
fromString :: String -> Builder
fromString str = Builder $ \k (Buffer p0 o0 u0 l0) ->
let loop !marr !o !u !l [] = k (Buffer marr o u l)
loop marr o u l s@(c:cs)
| l <= 1 = do
arr <- A.unsafeFreeze marr
let !t = Text arr o u
marr' <- A.new chunkSize
ts <- inlineInterleaveST (loop marr' 0 0 chunkSize s)
return $ t : ts
| otherwise = do
n <- unsafeWrite marr (o+u) c
loop marr o (u+n) (l-n) cs
in loop p0 o0 u0 l0 str
where
chunkSize = smallChunkSize
{-# INLINE fromString #-}
fromLazyText :: L.Text -> Builder
fromLazyText ts = flush `append` mapBuilder (L.toChunks ts ++)
{-# INLINE fromLazyText #-}
data Buffer s = Buffer {-# UNPACK #-} !(A.MArray s)
{-# UNPACK #-} !Int
{-# UNPACK #-} !Int
{-# UNPACK #-} !Int
toLazyText :: Builder -> L.Text
toLazyText = toLazyTextWith smallChunkSize
toLazyTextWith :: Int -> Builder -> L.Text
toLazyTextWith chunkSize m = L.fromChunks (runST $
newBuffer chunkSize >>= runBuilder (m `append` flush) (const (return [])))
flush :: Builder
flush = Builder $ \ k buf@(Buffer p o u l) ->
if u == 0
then k buf
else do arr <- A.unsafeFreeze p
let !b = Buffer p (o+u) 0 l
!t = Text arr o u
ts <- inlineInterleaveST (k b)
return $! t : ts
{-# INLINE [1] flush #-}
withBuffer :: (forall s. Buffer s -> ST s (Buffer s)) -> Builder
withBuffer f = Builder $ \k buf -> f buf >>= k
{-# INLINE withBuffer #-}
withSize :: (Int -> Builder) -> Builder
withSize f = Builder $ \ k buf@(Buffer _ _ _ l) ->
runBuilder (f l) k buf
{-# INLINE withSize #-}
mapBuilder :: ([S.Text] -> [S.Text]) -> Builder
mapBuilder f = Builder (fmap f .)
ensureFree :: Int -> Builder
ensureFree !n = withSize $ \ l ->
if n <= l
then empty
else flush `append'` withBuffer (const (newBuffer (max n smallChunkSize)))
{-# INLINE [0] ensureFree #-}
writeAtMost :: Int -> (forall s. A.MArray s -> Int -> ST s Int) -> Builder
writeAtMost n f = ensureFree n `append'` withBuffer (writeBuffer f)
{-# INLINE [0] writeAtMost #-}
writeN :: Int -> (forall s. A.MArray s -> Int -> ST s ()) -> Builder
writeN n f = writeAtMost n (\ p o -> f p o >> return n)
{-# INLINE writeN #-}
writeBuffer :: (A.MArray s -> Int -> ST s Int) -> Buffer s -> ST s (Buffer s)
writeBuffer f (Buffer p o u l) = do
n <- f p (o+u)
return $! Buffer p o (u+n) (l-n)
{-# INLINE writeBuffer #-}
newBuffer :: Int -> ST s (Buffer s)
newBuffer size = do
arr <- A.new size
return $! Buffer arr 0 0 size
{-# INLINE newBuffer #-}
append' :: Builder -> Builder -> Builder
append' (Builder f) (Builder g) = Builder (f . g)
{-# INLINE append' #-}
{-# RULES
"append/writeAtMost" forall a b (f::forall s. A.MArray s -> Int -> ST s Int)
(g::forall s. A.MArray s -> Int -> ST s Int) ws.
append (writeAtMost a f) (append (writeAtMost b g) ws) =
append (writeAtMost (a+b) (\marr o -> f marr o >>= \ n ->
g marr (o+n) >>= \ m ->
let s = n+m in s `seq` return s)) ws
"writeAtMost/writeAtMost" forall a b (f::forall s. A.MArray s -> Int -> ST s Int)
(g::forall s. A.MArray s -> Int -> ST s Int).
append (writeAtMost a f) (writeAtMost b g) =
writeAtMost (a+b) (\marr o -> f marr o >>= \ n ->
g marr (o+n) >>= \ m ->
let s = n+m in s `seq` return s)
"ensureFree/ensureFree" forall a b .
append (ensureFree a) (ensureFree b) = ensureFree (max a b)
"flush/flush"
append flush flush = flush
#-}