{-# LANGUAGE BangPatterns #-}
-- |
-- Module      :  Data.Attoparsec.ByteString.Buffer
-- Copyright   :  Bryan O'Sullivan 2007-2015
-- License     :  BSD3
--
-- Maintainer  :  bos@serpentine.com
-- Stability   :  experimental
-- Portability :  GHC
--
-- An "immutable" buffer that supports cheap appends.
--
-- A Buffer is divided into an immutable read-only zone, followed by a
-- mutable area that we've preallocated, but not yet written to.
--
-- We overallocate at the end of a Buffer so that we can cheaply
-- append.  Since a user of an existing Buffer cannot see past the end
-- of its immutable zone into the data that will change during an
-- append, this is safe.
--
-- Once we run out of space at the end of a Buffer, we do the usual
-- doubling of the buffer size.
--
-- The fact of having a mutable buffer really helps with performance,
-- but it does have a consequence: if someone misuses the Partial API
-- that attoparsec uses by calling the same continuation repeatedly
-- (which never makes sense in practice), they could overwrite data.
--
-- Since the API *looks* pure, it should *act* pure, too, so we use
-- two generation counters (one mutable, one immutable) to track the
-- number of appends to a mutable buffer. If the counters ever get out
-- of sync, someone is appending twice to a mutable buffer, so we
-- duplicate the entire buffer in order to preserve the immutability
-- of its older self.
--
-- While we could go a step further and gain protection against API
-- abuse on a multicore system, by use of an atomic increment
-- instruction to bump the mutable generation counter, that would be
-- very expensive, and feels like it would also be in the realm of the
-- ridiculous.  Clients should never call a continuation more than
-- once; we lack a linear type system that could enforce this; and
-- there's only so far we should go to accommodate broken uses.

module Data.Attoparsec.ByteString.Buffer
    (
      Buffer
    , buffer
    , unbuffer
    , pappend
    , length
    , unsafeIndex
    , substring
    , unsafeDrop
    ) where

import Control.Exception (assert)
import Data.ByteString.Internal (ByteString(..), memcpy, nullForeignPtr)
import Data.Attoparsec.Internal.Fhthagn (inlinePerformIO)
import Data.Attoparsec.Internal.Compat
import Data.List (foldl1')
import Data.Monoid as Mon (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Word (Word8)
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
import Foreign.Ptr (castPtr, plusPtr)
import Foreign.Storable (peek, peekByteOff, poke, sizeOf)
import GHC.ForeignPtr (mallocPlainForeignPtrBytes)
import Prelude hiding (length)

-- If _cap is zero, this buffer is empty.
data Buffer = Buf {
      Buffer -> ForeignPtr Word8
_fp  :: {-# UNPACK #-} !(ForeignPtr Word8)
    , Buffer -> Int
_off :: {-# UNPACK #-} !Int
    , Buffer -> Int
_len :: {-# UNPACK #-} !Int
    , Buffer -> Int
_cap :: {-# UNPACK #-} !Int
    , Buffer -> Int
_gen :: {-# UNPACK #-} !Int
    }

instance Show Buffer where
    showsPrec :: Int -> Buffer -> ShowS
showsPrec Int
p = Int -> ByteString -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p (ByteString -> ShowS) -> (Buffer -> ByteString) -> Buffer -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Buffer -> ByteString
unbuffer

-- | The initial 'Buffer' has no mutable zone, so we can avoid all
-- copies in the (hopefully) common case of no further input being fed
-- to us.
buffer :: ByteString -> Buffer
buffer :: ByteString -> Buffer
buffer ByteString
bs = ByteString -> (ForeignPtr Word8 -> Int -> Int -> Buffer) -> Buffer
forall r. ByteString -> (ForeignPtr Word8 -> Int -> Int -> r) -> r
withPS ByteString
bs ((ForeignPtr Word8 -> Int -> Int -> Buffer) -> Buffer)
-> (ForeignPtr Word8 -> Int -> Int -> Buffer) -> Buffer
forall a b. (a -> b) -> a -> b
$ \ForeignPtr Word8
fp Int
off Int
len -> ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Buffer
Buf ForeignPtr Word8
fp Int
off Int
len Int
len Int
0

unbuffer :: Buffer -> ByteString
unbuffer :: Buffer -> ByteString
unbuffer (Buf ForeignPtr Word8
fp Int
off Int
len Int
_ Int
_) = ForeignPtr Word8 -> Int -> Int -> ByteString
mkPS ForeignPtr Word8
fp Int
off Int
len

instance Semigroup Buffer where
    (Buf ForeignPtr Word8
_ Int
_ Int
_ Int
0 Int
_) <> :: Buffer -> Buffer -> Buffer
<> Buffer
b                    = Buffer
b
    Buffer
a               <> (Buf ForeignPtr Word8
_ Int
_ Int
_ Int
0 Int
_)      = Buffer
a
    Buffer
buf             <> (Buf ForeignPtr Word8
fp Int
off Int
len Int
_ Int
_) = Buffer -> ForeignPtr Word8 -> Int -> Int -> Buffer
forall a. Buffer -> ForeignPtr a -> Int -> Int -> Buffer
append Buffer
buf ForeignPtr Word8
fp Int
off Int
len

instance Monoid Buffer where
    mempty :: Buffer
mempty = ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Buffer
Buf ForeignPtr Word8
nullForeignPtr Int
0 Int
0 Int
0 Int
0

    mappend :: Buffer -> Buffer -> Buffer
mappend = Buffer -> Buffer -> Buffer
forall a. Semigroup a => a -> a -> a
(<>)

    mconcat :: [Buffer] -> Buffer
mconcat [] = Buffer
forall a. Monoid a => a
Mon.mempty
    mconcat [Buffer]
xs = (Buffer -> Buffer -> Buffer) -> [Buffer] -> Buffer
forall a. (a -> a -> a) -> [a] -> a
foldl1' Buffer -> Buffer -> Buffer
forall a. Monoid a => a -> a -> a
mappend [Buffer]
xs

pappend :: Buffer -> ByteString -> Buffer
pappend :: Buffer -> ByteString -> Buffer
pappend (Buf ForeignPtr Word8
_ Int
_ Int
_ Int
0 Int
_) ByteString
bs  = ByteString -> Buffer
buffer ByteString
bs
pappend Buffer
buf             ByteString
bs  = ByteString -> (ForeignPtr Word8 -> Int -> Int -> Buffer) -> Buffer
forall r. ByteString -> (ForeignPtr Word8 -> Int -> Int -> r) -> r
withPS ByteString
bs ((ForeignPtr Word8 -> Int -> Int -> Buffer) -> Buffer)
-> (ForeignPtr Word8 -> Int -> Int -> Buffer) -> Buffer
forall a b. (a -> b) -> a -> b
$ \ForeignPtr Word8
fp Int
off Int
len -> Buffer -> ForeignPtr Word8 -> Int -> Int -> Buffer
forall a. Buffer -> ForeignPtr a -> Int -> Int -> Buffer
append Buffer
buf ForeignPtr Word8
fp Int
off Int
len

append :: Buffer -> ForeignPtr a -> Int -> Int -> Buffer
append :: Buffer -> ForeignPtr a -> Int -> Int -> Buffer
append (Buf ForeignPtr Word8
fp0 Int
off0 Int
len0 Int
cap0 Int
gen0) !ForeignPtr a
fp1 !Int
off1 !Int
len1 =
  IO Buffer -> Buffer
forall a. IO a -> a
inlinePerformIO (IO Buffer -> Buffer)
-> ((Ptr Word8 -> IO Buffer) -> IO Buffer)
-> (Ptr Word8 -> IO Buffer)
-> Buffer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignPtr Word8 -> (Ptr Word8 -> IO Buffer) -> IO Buffer
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp0 ((Ptr Word8 -> IO Buffer) -> Buffer)
-> (Ptr Word8 -> IO Buffer) -> Buffer
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr0 ->
    ForeignPtr a -> (Ptr a -> IO Buffer) -> IO Buffer
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr a
fp1 ((Ptr a -> IO Buffer) -> IO Buffer)
-> (Ptr a -> IO Buffer) -> IO Buffer
forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr1 -> do
      let genSize :: Int
genSize = Int -> Int
forall a. Storable a => a -> Int
sizeOf (Int
0::Int)
          newlen :: Int
newlen  = Int
len0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len1
      Int
gen <- if Int
gen0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
             then Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
             else Ptr Int -> IO Int
forall a. Storable a => Ptr a -> IO a
peek (Ptr Word8 -> Ptr Int
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr0)
      if Int
gen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
gen0 Bool -> Bool -> Bool
&& Int
newlen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
cap0
        then do
          let newgen :: Int
newgen = Int
gen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
          Ptr Int -> Int -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8 -> Ptr Int
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr0) Int
newgen
          Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memcpy (Ptr Word8
ptr0 Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
off0Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
len0))
                 (Ptr a
ptr1 Ptr a -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off1)
                 (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len1)
          Buffer -> IO Buffer
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Buffer
Buf ForeignPtr Word8
fp0 Int
off0 Int
newlen Int
cap0 Int
newgen)
        else do
          let newcap :: Int
newcap = Int
newlen Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2
          ForeignPtr Word8
fp <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocPlainForeignPtrBytes (Int
newcap Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
genSize)
          ForeignPtr Word8 -> (Ptr Word8 -> IO Buffer) -> IO Buffer
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO Buffer) -> IO Buffer)
-> (Ptr Word8 -> IO Buffer) -> IO Buffer
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr_ -> do
            let ptr :: Ptr b
ptr    = Ptr Word8
ptr_ Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
genSize
                newgen :: Int
newgen = Int
1
            Ptr Int -> Int -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8 -> Ptr Int
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr_) Int
newgen
            Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memcpy Ptr Word8
forall b. Ptr b
ptr (Ptr Word8
ptr0 Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off0) (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len0)
            Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memcpy (Ptr Any
forall b. Ptr b
ptr Ptr Any -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
len0) (Ptr a
ptr1 Ptr a -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off1)
                   (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len1)
            Buffer -> IO Buffer
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Buffer
Buf ForeignPtr Word8
fp Int
genSize Int
newlen Int
newcap Int
newgen)

length :: Buffer -> Int
length :: Buffer -> Int
length (Buf ForeignPtr Word8
_ Int
_ Int
len Int
_ Int
_) = Int
len
{-# INLINE length #-}

unsafeIndex :: Buffer -> Int -> Word8
unsafeIndex :: Buffer -> Int -> Word8
unsafeIndex (Buf ForeignPtr Word8
fp Int
off Int
len Int
_ Int
_) Int
i = Bool -> Word8 -> Word8
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len) (Word8 -> Word8)
-> ((Ptr Word8 -> IO Word8) -> Word8)
-> (Ptr Word8 -> IO Word8)
-> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    IO Word8 -> Word8
forall a. IO a -> a
inlinePerformIO (IO Word8 -> Word8)
-> ((Ptr Word8 -> IO Word8) -> IO Word8)
-> (Ptr Word8 -> IO Word8)
-> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignPtr Word8 -> (Ptr Word8 -> IO Word8) -> IO Word8
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO Word8) -> Word8)
-> (Ptr Word8 -> IO Word8) -> Word8
forall a b. (a -> b) -> a -> b
$ (Ptr Word8 -> Int -> IO Word8) -> Int -> Ptr Word8 -> IO Word8
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr Word8 -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
i)
{-# INLINE unsafeIndex #-}

substring :: Int -> Int -> Buffer -> ByteString
substring :: Int -> Int -> Buffer -> ByteString
substring Int
s Int
l (Buf ForeignPtr Word8
fp Int
off Int
len Int
_ Int
_) =
  Bool -> ByteString -> ByteString
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len) (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Bool -> ByteString -> ByteString
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
s) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
  ForeignPtr Word8 -> Int -> Int -> ByteString
mkPS ForeignPtr Word8
fp (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
s) Int
l
{-# INLINE substring #-}

unsafeDrop :: Int -> Buffer -> ByteString
unsafeDrop :: Int -> Buffer -> ByteString
unsafeDrop Int
s (Buf ForeignPtr Word8
fp Int
off Int
len Int
_ Int
_) =
  Bool -> ByteString -> ByteString
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
  ForeignPtr Word8 -> Int -> Int -> ByteString
mkPS ForeignPtr Word8
fp (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
s) (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
s)
{-# INLINE unsafeDrop #-}