{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      : Data.Text.Internal.Builder
-- Copyright   : (c) 2013 Bryan O'Sullivan
--               (c) 2010 Johan Tibell
-- License     : BSD-style (see LICENSE)
--
-- Maintainer  : Johan Tibell <johan.tibell@gmail.com>
-- Stability   : experimental
-- Portability : portable to Hugs and GHC
--
-- /Warning/: this is an internal module, and does not have a stable
-- API or name. Functions in this module may not check or enforce
-- preconditions expected by public modules. Use at your own risk!
--
-- Efficient construction of lazy @Text@ values.  The principal
-- operations on a @Builder@ are @singleton@, @fromText@, and
-- @fromLazyText@, which construct new builders, and 'mappend', which
-- concatenates two builders.
--
-- To get maximum performance when building lazy @Text@ values using a
-- builder, associate @mappend@ calls to the right.  For example,
-- prefer
--
-- > singleton 'a' `mappend` (singleton 'b' `mappend` singleton 'c')
--
-- to
--
-- > singleton 'a' `mappend` singleton 'b' `mappend` singleton 'c'
--
-- as the latter associates @mappend@ to the left.
--
-----------------------------------------------------------------------------

module Data.Text.Internal.Builder
   ( -- * Public API
     -- ** The Builder type
     Builder
   , toLazyText
   , toLazyTextWith

     -- ** Constructing Builders
   , singleton
   , fromText
   , fromLazyText
   , fromString

     -- ** Flushing the buffer state
   , flush

     -- * Internal functions
   , append'
   , ensureFree
   , writeN
   ) where

import Control.Monad.ST (ST, runST)
import Data.Monoid (Monoid(..))
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup (Semigroup(..))
#endif
import Data.Text.Internal (Text(..), safe)
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

#if defined(ASSERTS)
import GHC.Stack (HasCallStack)
#endif

------------------------------------------------------------------------

-- | A @Builder@ is an efficient way to build lazy @Text@ values.
-- There are several functions for constructing builders, but only one
-- to inspect them: to extract any data, you have to turn them into
-- lazy @Text@ values using @toLazyText@.
--
-- Internally, a builder constructs a lazy @Text@ by filling arrays
-- piece by piece.  As each buffer is filled, it is \'popped\' off, to
-- become a new chunk of the resulting lazy @Text@.  All this is
-- hidden from the user of the @Builder@.
newtype Builder = Builder {
     -- Invariant (from Data.Text.Lazy):
     --      The lists include no null Texts.
     Builder
-> forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text]
runBuilder :: forall s. (Buffer s -> ST s [S.Text])
                -> Buffer s
                -> ST s [S.Text]
   }

instance Semigroup Builder where
   <> :: Builder -> Builder -> Builder
(<>) = Builder -> Builder -> Builder
append
   {-# INLINE (<>) #-}

instance Monoid Builder where
   mempty :: Builder
mempty  = Builder
empty
   {-# INLINE mempty #-}
   mappend :: Builder -> Builder -> Builder
mappend = forall a. Semigroup a => a -> a -> a
(<>)
   {-# INLINE mappend #-}
   mconcat :: [Builder] -> Builder
mconcat = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Monoid a => a -> a -> a
mappend forall a. Monoid a => a
Data.Monoid.mempty
   {-# INLINE mconcat #-}

instance String.IsString Builder where
    fromString :: String -> Builder
fromString = String -> Builder
fromString
    {-# INLINE fromString #-}

instance Show Builder where
    show :: Builder -> String
show = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText

instance Eq Builder where
    Builder
a == :: Builder -> Builder -> Bool
== Builder
b = Builder -> Text
toLazyText Builder
a forall a. Eq a => a -> a -> Bool
== Builder -> Text
toLazyText Builder
b

instance Ord Builder where
    Builder
a <= :: Builder -> Builder -> Bool
<= Builder
b = Builder -> Text
toLazyText Builder
a forall a. Ord a => a -> a -> Bool
<= Builder -> Text
toLazyText Builder
b

------------------------------------------------------------------------

-- | /O(1)./ The empty @Builder@, satisfying
--
--  * @'toLazyText' 'empty' = 'L.empty'@
--
empty :: Builder
empty :: Builder
empty = (forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text])
-> Builder
Builder (\ Buffer s -> ST s [Text]
k Buffer s
buf -> Buffer s -> ST s [Text]
k Buffer s
buf)
{-# INLINE empty #-}

-- | /O(1)./ A @Builder@ taking a single character, satisfying
--
--  * @'toLazyText' ('singleton' c) = 'L.singleton' c@
--
singleton ::
#if defined(ASSERTS)
  HasCallStack =>
#endif
  Char -> Builder
singleton :: Char -> Builder
singleton Char
c = Int -> (forall s. MArray s -> Int -> ST s Int) -> Builder
writeAtMost Int
2 forall a b. (a -> b) -> a -> b
$ \ MArray s
marr Int
o -> forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
marr Int
o (Char -> Char
safe Char
c)
{-# INLINE singleton #-}

------------------------------------------------------------------------

-- | /O(1)./ The concatenation of two builders, an associative
-- operation with identity 'empty', satisfying
--
--  * @'toLazyText' ('append' x y) = 'L.append' ('toLazyText' x) ('toLazyText' y)@
--
append :: Builder -> Builder -> Builder
append :: Builder -> Builder -> Builder
append (Builder forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text]
f) (Builder forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text]
g) = (forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text])
-> Builder
Builder (forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text]
g)
{-# INLINE [0] append #-}

-- TODO: Experiment to find the right threshold.
copyLimit :: Int
copyLimit :: Int
copyLimit = Int
128

-- This function attempts to merge small @Text@ values instead of
-- treating each value as its own chunk.  We may not always want this.

-- | /O(1)./ A @Builder@ taking a 'S.Text', satisfying
--
--  * @'toLazyText' ('fromText' t) = 'L.fromChunks' [t]@
--
fromText :: S.Text -> Builder
fromText :: Text -> Builder
fromText t :: Text
t@(Text Array
arr Int
off Int
l)
    | Text -> Bool
S.null Text
t       = Builder
empty
    | Int
l forall a. Ord a => a -> a -> Bool
<= Int
copyLimit = Int -> (forall s. MArray s -> Int -> ST s ()) -> Builder
writeN Int
l forall a b. (a -> b) -> a -> b
$ \MArray s
marr Int
o -> forall s. MArray s -> Int -> Array -> Int -> Int -> ST s ()
A.copyI MArray s
marr Int
o Array
arr Int
off (Int
lforall a. Num a => a -> a -> a
+Int
o)
    | Bool
otherwise      = Builder
flush Builder -> Builder -> Builder
`append` ([Text] -> [Text]) -> Builder
mapBuilder (Text
t forall a. a -> [a] -> [a]
:)
{-# INLINE [1] fromText #-}

{-# RULES
"fromText/pack" forall s .
        fromText (S.pack s) = fromString s
 #-}

-- | /O(1)./ A Builder taking a @String@, satisfying
--
--  * @'toLazyText' ('fromString' s) = 'L.fromChunks' [S.pack s]@
--
fromString :: String -> Builder
fromString :: String -> Builder
fromString String
str = (forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text])
-> Builder
Builder forall a b. (a -> b) -> a -> b
$ \Buffer s -> ST s [Text]
k (Buffer MArray s
p0 Int
o0 Int
u0 Int
l0) ->
    let loop :: MArray s -> Int -> Int -> Int -> String -> ST s [Text]
loop !MArray s
marr !Int
o !Int
u !Int
l [] = Buffer s -> ST s [Text]
k (forall s. MArray s -> Int -> Int -> Int -> Buffer s
Buffer MArray s
marr Int
o Int
u Int
l)
        loop MArray s
marr Int
o Int
u Int
l s :: String
s@(Char
c:String
cs)
            | Int
l forall a. Ord a => a -> a -> Bool
<= Int
1 = do
                Array
arr <- forall s. MArray s -> ST s Array
A.unsafeFreeze MArray s
marr
                let !t :: Text
t = Array -> Int -> Int -> Text
Text Array
arr Int
o Int
u
                MArray s
marr' <- forall s. Int -> ST s (MArray s)
A.new Int
chunkSize
                [Text]
ts <- forall s a. ST s a -> ST s a
inlineInterleaveST (MArray s -> Int -> Int -> Int -> String -> ST s [Text]
loop MArray s
marr' Int
0 Int
0 Int
chunkSize String
s)
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
t forall a. a -> [a] -> [a]
: [Text]
ts
            | Bool
otherwise = do
                Int
n <- forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
marr (Int
oforall a. Num a => a -> a -> a
+Int
u) (Char -> Char
safe Char
c)
                MArray s -> Int -> Int -> Int -> String -> ST s [Text]
loop MArray s
marr Int
o (Int
uforall a. Num a => a -> a -> a
+Int
n) (Int
lforall a. Num a => a -> a -> a
-Int
n) String
cs
    in MArray s -> Int -> Int -> Int -> String -> ST s [Text]
loop MArray s
p0 Int
o0 Int
u0 Int
l0 String
str
  where
    chunkSize :: Int
chunkSize = Int
smallChunkSize
{-# INLINE fromString #-}

-- | /O(1)./ A @Builder@ taking a lazy @Text@, satisfying
--
--  * @'toLazyText' ('fromLazyText' t) = t@
--
fromLazyText :: L.Text -> Builder
fromLazyText :: Text -> Builder
fromLazyText Text
ts = Builder
flush Builder -> Builder -> Builder
`append` ([Text] -> [Text]) -> Builder
mapBuilder (Text -> [Text]
L.toChunks Text
ts forall a. [a] -> [a] -> [a]
++)
{-# INLINE fromLazyText #-}

------------------------------------------------------------------------

-- Our internal buffer type
data Buffer s = Buffer {-# UNPACK #-} !(A.MArray s)
                       {-# UNPACK #-} !Int  -- offset
                       {-# UNPACK #-} !Int  -- used units
                       {-# UNPACK #-} !Int  -- length left

------------------------------------------------------------------------

-- | /O(n)./ Extract a lazy @Text@ from a @Builder@ with a default
-- buffer size.  The construction work takes place if and when the
-- relevant part of the lazy @Text@ is demanded.
toLazyText :: Builder -> L.Text
toLazyText :: Builder -> Text
toLazyText = Int -> Builder -> Text
toLazyTextWith Int
smallChunkSize

-- | /O(n)./ Extract a lazy @Text@ from a @Builder@, using the given
-- size for the initial buffer.  The construction work takes place if
-- and when the relevant part of the lazy @Text@ is demanded.
--
-- If the initial buffer is too small to hold all data, subsequent
-- buffers will be the default buffer size.
toLazyTextWith :: Int -> Builder -> L.Text
toLazyTextWith :: Int -> Builder -> Text
toLazyTextWith Int
chunkSize Builder
m = [Text] -> Text
L.fromChunks (forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$
  forall s. Int -> ST s (Buffer s)
newBuffer Int
chunkSize forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Builder
-> forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text]
runBuilder (Builder
m Builder -> Builder -> Builder
`append` Builder
flush) (forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return [])))

-- | /O(1)./ Pop the strict @Text@ we have constructed so far, if any,
-- yielding a new chunk in the result lazy @Text@.
flush :: Builder
flush :: Builder
flush = (forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text])
-> Builder
Builder forall a b. (a -> b) -> a -> b
$ \ Buffer s -> ST s [Text]
k buf :: Buffer s
buf@(Buffer MArray s
p Int
o Int
u Int
l) ->
    if Int
u forall a. Eq a => a -> a -> Bool
== Int
0
    then Buffer s -> ST s [Text]
k Buffer s
buf
    else do Array
arr <- forall s. MArray s -> ST s Array
A.unsafeFreeze MArray s
p
            let !b :: Buffer s
b = forall s. MArray s -> Int -> Int -> Int -> Buffer s
Buffer MArray s
p (Int
oforall a. Num a => a -> a -> a
+Int
u) Int
0 Int
l
                !t :: Text
t = Array -> Int -> Int -> Text
Text Array
arr Int
o Int
u
            [Text]
ts <- forall s a. ST s a -> ST s a
inlineInterleaveST (Buffer s -> ST s [Text]
k Buffer s
b)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Text
t forall a. a -> [a] -> [a]
: [Text]
ts
{-# INLINE [1] flush #-}
-- defer inlining so that flush/flush rule may fire.

------------------------------------------------------------------------

-- | Sequence an ST operation on the buffer
withBuffer :: (forall s. Buffer s -> ST s (Buffer s)) -> Builder
withBuffer :: (forall s. Buffer s -> ST s (Buffer s)) -> Builder
withBuffer forall s. Buffer s -> ST s (Buffer s)
f = (forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text])
-> Builder
Builder forall a b. (a -> b) -> a -> b
$ \Buffer s -> ST s [Text]
k Buffer s
buf -> forall s. Buffer s -> ST s (Buffer s)
f Buffer s
buf forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Buffer s -> ST s [Text]
k
{-# INLINE withBuffer #-}

-- | Get the size of the buffer
withSize :: (Int -> Builder) -> Builder
withSize :: (Int -> Builder) -> Builder
withSize Int -> Builder
f = (forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text])
-> Builder
Builder forall a b. (a -> b) -> a -> b
$ \ Buffer s -> ST s [Text]
k buf :: Buffer s
buf@(Buffer MArray s
_ Int
_ Int
_ Int
l) ->
    Builder
-> forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text]
runBuilder (Int -> Builder
f Int
l) Buffer s -> ST s [Text]
k Buffer s
buf
{-# INLINE withSize #-}

-- | Map the resulting list of texts.
mapBuilder :: ([S.Text] -> [S.Text]) -> Builder
mapBuilder :: ([Text] -> [Text]) -> Builder
mapBuilder [Text] -> [Text]
f = (forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text])
-> Builder
Builder (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> [Text]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

------------------------------------------------------------------------

-- | Ensure that there are at least @n@ many elements available.
ensureFree :: Int -> Builder
ensureFree :: Int -> Builder
ensureFree !Int
n = (Int -> Builder) -> Builder
withSize forall a b. (a -> b) -> a -> b
$ \ Int
l ->
    if Int
n forall a. Ord a => a -> a -> Bool
<= Int
l
    then Builder
empty
    else Builder
flush Builder -> Builder -> Builder
`append'` (forall s. Buffer s -> ST s (Buffer s)) -> Builder
withBuffer (forall a b. a -> b -> a
const (forall s. Int -> ST s (Buffer s)
newBuffer (forall a. Ord a => a -> a -> a
max Int
n Int
smallChunkSize)))
{-# INLINE [0] ensureFree #-}

writeAtMost :: Int -> (forall s. A.MArray s -> Int -> ST s Int) -> Builder
writeAtMost :: Int -> (forall s. MArray s -> Int -> ST s Int) -> Builder
writeAtMost Int
n forall s. MArray s -> Int -> ST s Int
f = Int -> Builder
ensureFree Int
n Builder -> Builder -> Builder
`append'` (forall s. Buffer s -> ST s (Buffer s)) -> Builder
withBuffer (forall s.
(MArray s -> Int -> ST s Int) -> Buffer s -> ST s (Buffer s)
writeBuffer forall s. MArray s -> Int -> ST s Int
f)
{-# INLINE [0] writeAtMost #-}

-- | Ensure that @n@ many elements are available, and then use @f@ to
-- write some elements into the memory.
writeN :: Int -> (forall s. A.MArray s -> Int -> ST s ()) -> Builder
writeN :: Int -> (forall s. MArray s -> Int -> ST s ()) -> Builder
writeN Int
n forall s. MArray s -> Int -> ST s ()
f = Int -> (forall s. MArray s -> Int -> ST s Int) -> Builder
writeAtMost Int
n (\ MArray s
p Int
o -> forall s. MArray s -> Int -> ST s ()
f MArray s
p Int
o forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Int
n)
{-# INLINE writeN #-}

writeBuffer :: (A.MArray s -> Int -> ST s Int) -> Buffer s -> ST s (Buffer s)
writeBuffer :: forall s.
(MArray s -> Int -> ST s Int) -> Buffer s -> ST s (Buffer s)
writeBuffer MArray s -> Int -> ST s Int
f (Buffer MArray s
p Int
o Int
u Int
l) = do
    Int
n <- MArray s -> Int -> ST s Int
f MArray s
p (Int
oforall a. Num a => a -> a -> a
+Int
u)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall s. MArray s -> Int -> Int -> Int -> Buffer s
Buffer MArray s
p Int
o (Int
uforall a. Num a => a -> a -> a
+Int
n) (Int
lforall a. Num a => a -> a -> a
-Int
n)
{-# INLINE writeBuffer #-}

newBuffer :: Int -> ST s (Buffer s)
newBuffer :: forall s. Int -> ST s (Buffer s)
newBuffer Int
size = do
    MArray s
arr <- forall s. Int -> ST s (MArray s)
A.new Int
size
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall s. MArray s -> Int -> Int -> Int -> Buffer s
Buffer MArray s
arr Int
0 Int
0 Int
size
{-# INLINE newBuffer #-}

------------------------------------------------------------------------
-- Some nice rules for Builder

-- This function makes GHC understand that 'writeN' and 'ensureFree'
-- are *not* recursive in the precense of the rewrite rules below.
-- This is not needed with GHC 7+.
append' :: Builder -> Builder -> Builder
append' :: Builder -> Builder -> Builder
append' (Builder forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text]
f) (Builder forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text]
g) = (forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text])
-> Builder
Builder (forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. (Buffer s -> ST s [Text]) -> Buffer s -> ST s [Text]
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

 #-}