ByteString.hs

-- | This module spends a lot of time fiddling around with 'Data.ByteString'
-- internals to work around <http://hackage.haskell.org/trac/ghc/ticket/7556> on
-- older Haskell Platforms and to improve constant and asymptotic factors in our
-- performance.
----------------------------------------------------------------------------
module Optics.Extra.Internal.ByteString
  ( traversedStrictTree
  , traversedStrictTree8
  , traversedLazy
  , traversedLazy8
  ) where

import Data.Bits
import Data.Char
import Data.Int
import Data.Word
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable
import GHC.Base (unsafeChr)
import GHC.ForeignPtr (mallocPlainForeignPtrBytes)
import GHC.IO (unsafeDupablePerformIO)
import qualified Data.ByteString            as B
import qualified Data.ByteString.Char8      as B8
import qualified Data.ByteString.Lazy       as BL
import qualified Data.ByteString.Lazy.Char8 as BL8
import qualified Data.ByteString.Internal   as BI
import qualified Data.ByteString.Unsafe     as BU

import Data.Profunctor.Indexed

import Optics.Core
import Optics.Internal.Fold
import Optics.Internal.IxFold
import Optics.Internal.Optic

-- | Traverse a strict 'B.ByteString' in a relatively balanced fashion, as a
-- balanced tree with biased runs of elements at the leaves.
traversedStrictTree :: IxTraversal' Int64 B.ByteString Word8
traversedStrictTree = Optic traversedStrictTree__
{-# INLINE traversedStrictTree #-}

-- | Traverse a strict 'B.ByteString' in a relatively balanced fashion, as a
-- balanced tree with biased runs of elements at the leaves, pretending the
-- bytes are chars.
traversedStrictTree8 :: IxTraversal' Int64 B8.ByteString Char
traversedStrictTree8 = Optic traversedStrictTree8__
{-# INLINE traversedStrictTree8 #-}

-- | An 'IxTraversal' of the individual bytes in a lazy 'BL.ByteString'.
traversedLazy :: IxTraversal' Int64 BL.ByteString Word8
traversedLazy = Optic traversedLazy__
{-# INLINE traversedLazy #-}

-- | An 'IxTraversal' of the individual bytes in a lazy 'BL.ByteString'
-- pretending the bytes are chars.
traversedLazy8 :: IxTraversal' Int64 BL.ByteString Char
traversedLazy8 = Optic traversedLazy8__
{-# INLINE traversedLazy8 #-}

----------------------------------------
-- Internal implementations

grain :: Int64
grain = 32
{-# INLINE grain #-}

-- | Internal version of 'traversedStrictTree'.
traversedStrictTree__
  :: Traversing p
  => Optic__ p j (Int64 -> j) B.ByteString B.ByteString Word8 Word8
traversedStrictTree__ = iwander $ \f bs ->
  let len = B.length bs
      go !i !j
        | i + grain < j, k <- i + shiftR (j - i) 1 =
            (\l r q -> l q >> r q) <$> go i k <*> go k j
        | otherwise = run i j
      run !(i::Int64) !(j::Int64)
        | i == j    = pure (\_ -> return ())
        | otherwise =
          let !i' = fromIntegral i
              !x  = BU.unsafeIndex bs i'
          in (\y ys q -> pokeByteOff q i' y >> ys q)
               <$> f i x
               <*> run (i + 1) j
  in unsafeCreate len <$> go 0 (fromIntegral len)
{-# INLINE [0] traversedStrictTree__ #-}

{-# RULES

"bytes -> map"
  forall (o :: FunArrow j Word8 Word8). traversedStrictTree__ o
                                      = roam B.map (reFunArrow o)
    :: FunArrow (Int64 -> j) B.ByteString B.ByteString

"bytes -> imap"
  forall (o :: IxFunArrow j Word8 Word8). traversedStrictTree__ o = iroam imapB o
    :: IxFunArrow (Int64 -> j) B.ByteString B.ByteString

"bytes -> foldr"
  forall (o :: Forget r j Word8 Word8). traversedStrictTree__ o
                                      = foldring__ B.foldr (reForget o)
    :: Forget r (Int64 -> j) B.ByteString B.ByteString

"bytes -> ifoldr"
  forall (o :: IxForget r j Word8 Word8). traversedStrictTree__ o
                                        = ifoldring__ ifoldrB o
    :: IxForget r (Int64 -> j) B.ByteString B.ByteString

#-}

-- | Indexed setter for 'traversedStrictTree__'.
imapB :: (Int64 -> Word8 -> Word8) -> B.ByteString -> B.ByteString
imapB f = snd . B.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0
{-# INLINE imapB #-}

-- | Indexed fold for 'traversedStrictTree__'.
ifoldrB :: (Int64 -> Word8 -> a -> a) -> a -> B.ByteString -> a
ifoldrB f z xs = B.foldr (\x g i -> i `seq` f i x (g (i + 1))) (const z) xs 0
{-# INLINE ifoldrB #-}

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

-- | Internal version of 'traversedStrictTree8'.
traversedStrictTree8__
  :: Traversing p
  => Optic__ p j (Int64 -> j) B8.ByteString B8.ByteString Char Char
traversedStrictTree8__ = iwander $ \f bs ->
  let len = B.length bs
      go !i !j
        | i + grain < j, k <- i + shiftR (j - i) 1 =
            (\l r q -> l q >> r q) <$> go i k <*> go k j
        | otherwise = run i j
      run !(i::Int64) !(j::Int64)
        | i == j    = pure (\_ -> return ())
        | otherwise =
          let !i' = fromIntegral i
              !x  = BU.unsafeIndex bs i'
          in (\y ys q -> pokeByteOff q i' (c2w y) >> ys q)
               <$> f i (w2c x)
               <*> run (i + 1) j
  in unsafeCreate len <$> go 0 (fromIntegral len)
{-# INLINE [0] traversedStrictTree8__ #-}

{-# RULES

"chars -> map"
  forall (o :: FunArrow j Char Char). traversedStrictTree8__ o
                                    = roam B8.map (reFunArrow o)
    :: FunArrow (Int64 -> j) B8.ByteString B8.ByteString

"chars -> imap"
  forall (o :: IxFunArrow j Char Char). traversedStrictTree8__ o = iroam imapB8 o
    :: IxFunArrow (Int64 -> j) B8.ByteString B8.ByteString

"chars -> foldr"
  forall (o :: Forget r j Char Char). traversedStrictTree8__ o
                                    = foldring__ B8.foldr (reForget o)
    :: Forget r (Int64 -> j) B8.ByteString B8.ByteString

"chars -> ifoldr"
  forall (o :: IxForget r j Char Char). traversedStrictTree8__ o
                                      = ifoldring__ ifoldrB8 o
    :: IxForget r (Int64 -> j) B8.ByteString B8.ByteString

#-}

-- | Indexed setter for 'traversedStrictTree8__'.
imapB8 :: (Int64 -> Char -> Char) -> B.ByteString -> B.ByteString
imapB8 f = snd . B8.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0
{-# INLINE imapB8 #-}

-- | Indexed fold for 'traversedStrictTree8__'.
ifoldrB8 :: (Int64 -> Char -> a -> a) -> a -> B.ByteString -> a
ifoldrB8 f z xs = B8.foldr (\x g i -> i `seq` f i x (g (i + 1))) (const z) xs 0
{-# INLINE ifoldrB8 #-}

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

-- | Internal version of 'traversedLazy'.
traversedLazy__
  :: Traversing p
  => Optic__ p j (Int64 -> j) BL.ByteString BL.ByteString Word8 Word8
traversedLazy__ = iwander $ \f lbs ->
  let go c fcs acc =
        let !acc' = acc + fromIntegral (B.length c)
            rest = reindexed (\x -> acc + x) traversedStrictTree
        in BL.append . BL.fromStrict <$> itraverseOf rest f c <*> fcs acc'
  in BL.foldrChunks go (\_ -> pure BL.empty) lbs 0
{-# INLINE [1] traversedLazy__ #-}

{-# RULES

"sets lazy bytestring"
  forall (o :: FunArrow j Word8 Word8). traversedLazy__ o
                                      = roam BL.map (reFunArrow o)
    :: FunArrow (Int64 -> j) BL.ByteString BL.ByteString

"isets lazy bytestring"
  forall (o :: IxFunArrow j Word8 Word8). traversedLazy__ o = iroam imapBL o
    :: IxFunArrow (Int64 -> j) BL.ByteString BL.ByteString

"gets lazy bytestring"
  forall (o :: Forget r j Word8 Word8). traversedLazy__ o
                                      = foldring__ BL.foldr (reForget o)
    :: Forget r (Int64 -> j) BL.ByteString BL.ByteString

"igets lazy bytestring"
  forall (o :: IxForget r j Word8 Word8). traversedLazy__ o = ifoldring__ ifoldrBL o
    :: IxForget r (Int64 -> j) BL.ByteString BL.ByteString

#-}

-- | Indexed setter for 'traversedLazy__'.
imapBL :: (Int64 -> Word8 -> Word8) -> BL.ByteString -> BL.ByteString
imapBL f = snd . BL.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0
{-# INLINE imapBL #-}

-- | Indexed fold for 'traversedLazy__'.
ifoldrBL :: (Int64 -> Word8 -> a -> a) -> a -> BL.ByteString -> a
ifoldrBL f z xs = BL.foldr (\x g i -> i `seq` f i x (g (i + 1))) (const z) xs 0
{-# INLINE ifoldrBL #-}

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

-- | Internal version of 'traversedLazy8'.
traversedLazy8__
  :: Traversing p
  => Optic__ p j (Int64 -> j) BL.ByteString BL.ByteString Char Char
traversedLazy8__ = iwander $ \f lbs ->
  let go c fcs acc =
        let !acc' = acc + fromIntegral (B.length c)
            rest = reindexed (\x -> acc + x) traversedStrictTree8
        in BL.append . BL.fromStrict <$> itraverseOf rest f c <*> fcs acc'
  in BL.foldrChunks go (\_ -> pure BL.empty) lbs 0
{-# INLINE [1] traversedLazy8__ #-}

{-# RULES

"sets lazy char bytestring"
  forall (o :: FunArrow j Char Char). traversedLazy8__ o
                                    = roam BL8.map (reFunArrow o)
    :: FunArrow (Int64 -> j) BL8.ByteString BL8.ByteString

"isets lazy char bytestring"
  forall (o :: IxFunArrow j Char Char). traversedLazy8__ o = iroam imapBL8 o
    :: IxFunArrow (Int64 -> j) BL8.ByteString BL8.ByteString

"gets lazy char bytestring"
  forall (o :: Forget r j Char Char). traversedLazy8__ o
                                    = foldring__ BL8.foldr (reForget o)
    :: Forget r (Int64 -> j) BL8.ByteString BL8.ByteString

"igets lazy char bytestring"
  forall (o :: IxForget r j Char Char). traversedLazy8__ o = ifoldring__ ifoldrBL8 o
    :: IxForget r (Int64 -> j) BL.ByteString BL.ByteString

#-}

-- | Indexed setter for 'traversedLazy8__'.
imapBL8 :: (Int64 -> Char -> Char) -> BL8.ByteString -> BL8.ByteString
imapBL8 f = snd . BL8.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0
{-# INLINE imapBL8 #-}

-- | Indexed fold for 'traversedLazy8__'.
ifoldrBL8 :: (Int64 -> Char -> a -> a) -> a -> BL8.ByteString -> a
ifoldrBL8 f z xs = BL8.foldr (\x g i -> i `seq` f i x (g (i + 1))) (const z) xs 0
{-# INLINE ifoldrBL8 #-}

------------------------------------------------------------------------------
-- ByteString guts
------------------------------------------------------------------------------

-- | Conversion between 'Word8' and 'Char'. Should compile to a no-op.
w2c :: Word8 -> Char
w2c = unsafeChr . fromIntegral
{-# INLINE w2c #-}

-- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and silently
-- truncates to 8 bits Chars > '\255'. It is provided as convenience for
-- ByteString construction.
c2w :: Char -> Word8
c2w = fromIntegral . ord
{-# INLINE c2w #-}

-- | A way of creating ByteStrings outside the IO monad. The @Int@ argument
-- gives the final size of the ByteString. Unlike 'createAndTrim' the ByteString
-- is not reallocated if the final size is less than the estimated size.
unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> B.ByteString
unsafeCreate l f = unsafeDupablePerformIO (create l f)
{-# INLINE unsafeCreate #-}

-- | Create ByteString of size @l@ and use action @f@ to fill it's contents.
create :: Int -> (Ptr Word8 -> IO ()) -> IO B.ByteString
create l f = do
    fp <- mallocPlainForeignPtrBytes l
    withForeignPtr fp $ \p -> f p
    return $! BI.PS fp 0 l
{-# INLINE create #-}