{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module Streaming.ByteString.Char8
(
ByteStream
, ByteString
, empty
, pack
, unpack
, string
, unlines
, unwords
, singleton
, fromChunks
, fromLazy
, fromStrict
, toChunks
, toLazy
, toLazy_
, toStrict
, toStrict_
, effects
, copy
, drained
, mwrap
, map
, intercalate
, intersperse
, cons
, cons'
, snoc
, append
, filter
, head
, head_
, last
, last_
, null
, null_
, nulls
, testNull
, uncons
, nextChar
, skipSomeWS
, break
, drop
, dropWhile
, group
, groupBy
, span
, splitAt
, splitWith
, take
, takeWhile
, split
, lines
, lineSplit
, words
, concat
, denull
, toStreamingByteString
, toStreamingByteStringWith
, toBuilder
, concatBuilders
, repeat
, iterate
, cycle
, unfoldr
, unfoldM
, reread
, fold
, fold_
, length
, length_
, count
, count_
, readInt
, getContents
, stdin
, stdout
, interact
, putStr
, putStrLn
, readFile
, writeFile
, appendFile
, fromHandle
, toHandle
, hGet
, hGetContents
, hGetContentsN
, hGetN
, hGetNonBlocking
, hGetNonBlockingN
, hPut
, unconsChunk
, nextChunk
, chunk
, foldrChunks
, foldlChunks
, chunkFold
, chunkFoldM
, chunkMap
, chunkMapM
, chunkMapM_
, dematerialize
, materialize
, distribute
, zipWithStream
) where
import Prelude hiding
(all, any, appendFile, break, concat, concatMap, cycle, drop, dropWhile,
elem, filter, foldl, foldl1, foldr, foldr1, getContents, getLine, head,
init, interact, iterate, last, length, lines, map, maximum, minimum,
notElem, null, putStr, putStrLn, readFile, repeat, replicate, reverse,
scanl, scanl1, scanr, scanr1, span, splitAt, tail, take, takeWhile,
unlines, unwords, unzip, words, writeFile, zip, zipWith)
import qualified Prelude
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as Char8
import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Unsafe as B
import Streaming hiding (concats, distribute, unfold)
import Streaming.Internal (Stream(..))
import qualified Streaming.Prelude as SP
import qualified Streaming.ByteString as Q
import Streaming.ByteString.Internal
import Streaming.ByteString
(append, appendFile, concat, concatBuilders, cycle, denull, distribute,
drained, drop, effects, empty, fromChunks, fromHandle, fromLazy,
fromStrict, getContents, group, hGet, hGetContents, hGetContentsN, hGetN,
hGetNonBlocking, hGetNonBlockingN, hPut, interact, intercalate, length,
length_, nextChunk, null, null_, nulls, readFile, splitAt, stdin, stdout,
take, testNull, toBuilder, toChunks, toHandle, toLazy, toLazy_,
toStreamingByteString, toStreamingByteStringWith, toStrict, toStrict_,
unconsChunk, writeFile, zipWithStream)
import Data.Bits ((.&.))
import Data.Word (Word8)
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Ptr
import Foreign.Storable
import qualified System.IO as IO
unpack :: Monad m => ByteStream m r -> Stream (Of Char) m r
unpack bs = case bs of
Empty r -> Return r
Go m -> Effect (fmap unpack m)
Chunk c cs -> unpackAppendCharsLazy c (unpack cs)
where
unpackAppendCharsLazy :: B.ByteString -> Stream (Of Char) m r -> Stream (Of Char) m r
unpackAppendCharsLazy (B.PS fp off len) xs
| len <= 100 = unpackAppendCharsStrict (B.PS fp off len) xs
| otherwise = unpackAppendCharsStrict (B.PS fp off 100) remainder
where
remainder = unpackAppendCharsLazy (B.PS fp (off+100) (len-100)) xs
unpackAppendCharsStrict :: B.ByteString -> Stream (Of Char) m r -> Stream (Of Char) m r
unpackAppendCharsStrict (B.PS fp off len) xs =
B.accursedUnutterablePerformIO $ withForeignPtr fp $ \base -> do
loop (base `plusPtr` (off-1)) (base `plusPtr` (off-1+len)) xs
where
loop !sentinal !p acc
| p == sentinal = return acc
| otherwise = do x <- peek p
loop sentinal (p `plusPtr` (-1)) (Step (B.w2c x :> acc))
{-# INLINABLE unpack #-}
pack :: Monad m => Stream (Of Char) m r -> ByteStream m r
pack = fromChunks
. mapped (fmap (\(str :> r) -> Char8.pack str :> r) . SP.toList)
. chunksOf 32
{-# INLINABLE pack #-}
cons :: Monad m => Char -> ByteStream m r -> ByteStream m r
cons c = Q.cons (c2w c)
{-# INLINE cons #-}
singleton :: Monad m => Char -> ByteStream m ()
singleton = Q.singleton . c2w
{-# INLINE singleton #-}
cons' :: Char -> ByteStream m r -> ByteStream m r
cons' c (Chunk bs bss) | B.length bs < 16 = Chunk (B.cons (c2w c) bs) bss
cons' c cs = Chunk (B.singleton (c2w c)) cs
{-# INLINE cons' #-}
snoc :: Monad m => ByteStream m r -> Char -> ByteStream m r
snoc cs = Q.snoc cs . c2w
{-# INLINE snoc #-}
head_ :: Monad m => ByteStream m r -> m Char
head_ = fmap w2c . Q.head_
{-# INLINE head_ #-}
head :: Monad m => ByteStream m r -> m (Of (Maybe Char) r)
head = fmap (\(m:>r) -> fmap w2c m :> r) . Q.head
{-# INLINE head #-}
last_ :: Monad m => ByteStream m r -> m Char
last_ = fmap w2c . Q.last_
{-# INLINE last_ #-}
last :: Monad m => ByteStream m r -> m (Of (Maybe Char) r)
last = fmap (\(m:>r) -> fmap w2c m :> r) . Q.last
{-# INLINE last #-}
groupBy :: Monad m => (Char -> Char -> Bool) -> ByteStream m r -> Stream (ByteStream m) m r
groupBy rel = Q.groupBy (\w w' -> rel (w2c w) (w2c w'))
{-# INLINE groupBy #-}
uncons :: Monad m => ByteStream m r -> m (Either r (Char, ByteStream m r))
uncons (Chunk c@(B.length -> len) cs)
| len > 0 = let !h = w2c $ B.unsafeHead c
!t = if len > 1 then Chunk (B.unsafeTail c) cs else cs
in return $ Right (h, t)
| otherwise = uncons cs
uncons (Go m) = m >>= uncons
uncons (Empty r) = return (Left r)
{-# INLINABLE uncons #-}
nextChar :: Monad m => ByteStream m r -> m (Either r (Char, ByteStream m r))
nextChar = uncons
{-# INLINABLE nextChar #-}
{-# DEPRECATED nextChar "Use uncons instead." #-}
map :: Monad m => (Char -> Char) -> ByteStream m r -> ByteStream m r
map f = Q.map (c2w . f . w2c)
{-# INLINE map #-}
intersperse :: Monad m => Char -> ByteStream m r -> ByteStream m r
intersperse c = Q.intersperse (c2w c)
{-# INLINE intersperse #-}
fold_ :: Monad m => (x -> Char -> x) -> x -> (x -> b) -> ByteStream m () -> m b
fold_ step begin done p0 = loop p0 begin
where
loop p !x = case p of
Chunk bs bss -> loop bss $! Char8.foldl' step x bs
Go m -> m >>= \p' -> loop p' x
Empty _ -> return (done x)
{-# INLINABLE fold_ #-}
fold :: Monad m => (x -> Char -> x) -> x -> (x -> b) -> ByteStream m r -> m (Of b r)
fold step begin done p0 = loop p0 begin
where
loop p !x = case p of
Chunk bs bss -> loop bss $! Char8.foldl' step x bs
Go m -> m >>= \p' -> loop p' x
Empty r -> return (done x :> r)
{-# INLINABLE fold #-}
iterate :: (Char -> Char) -> Char -> ByteStream m r
iterate f c = Q.iterate (c2w . f . w2c) (c2w c)
{-# INLINE iterate #-}
repeat :: Char -> ByteStream m r
repeat = Q.repeat . c2w
{-# INLINE repeat #-}
unfoldM :: Monad m => (a -> Maybe (Char, a)) -> a -> ByteStream m ()
unfoldM f = Q.unfoldM go where
go a = case f a of
Nothing -> Nothing
Just (c,a') -> Just (c2w c, a')
{-# INLINE unfoldM #-}
unfoldr :: (a -> Either r (Char, a)) -> a -> ByteStream m r
unfoldr step = Q.unfoldr (either Left (\(c,a) -> Right (c2w c,a)) . step)
{-# INLINE unfoldr #-}
takeWhile :: Monad m => (Char -> Bool) -> ByteStream m r -> ByteStream m ()
takeWhile f = Q.takeWhile (f . w2c)
{-# INLINE takeWhile #-}
dropWhile :: Monad m => (Char -> Bool) -> ByteStream m r -> ByteStream m r
dropWhile f = Q.dropWhile (f . w2c)
{-# INLINE dropWhile #-}
break :: Monad m => (Char -> Bool) -> ByteStream m r -> ByteStream m (ByteStream m r)
break f = Q.break (f . w2c)
{-# INLINE break #-}
span :: Monad m => (Char -> Bool) -> ByteStream m r -> ByteStream m (ByteStream m r)
span p = break (not . p)
{-# INLINE span #-}
splitWith :: Monad m => (Char -> Bool) -> ByteStream m r -> Stream (ByteStream m) m r
splitWith f = Q.splitWith (f . w2c)
{-# INLINE splitWith #-}
split :: Monad m => Char -> ByteStream m r -> Stream (ByteStream m) m r
split c = Q.split (c2w c)
{-# INLINE split #-}
filter :: Monad m => (Char -> Bool) -> ByteStream m r -> ByteStream m r
filter p = Q.filter (p . w2c)
{-# INLINE filter #-}
lines :: forall m r . Monad m => ByteStream m r -> Stream (ByteStream m) m r
lines text0 = loop1 text0
where
loop1 :: ByteStream m r -> Stream (ByteStream m) m r
loop1 text =
case text of
Empty r -> Return r
Go m -> Effect $ fmap loop1 m
Chunk c cs
| B.null c -> loop1 cs
| otherwise -> Step (loop2 False text)
loop2 :: Bool -> ByteStream m r -> ByteStream m (Stream (ByteStream m) m r)
loop2 prevCr text =
case text of
Empty r -> if prevCr
then Chunk (B.singleton 13) (Empty (Return r))
else Empty (Return r)
Go m -> Go $ fmap (loop2 prevCr) m
Chunk c cs ->
case B.elemIndex 10 c of
Nothing -> if B.null c
then loop2 prevCr cs
else if unsafeLast c == 13
then Chunk (unsafeInit c) (loop2 True cs)
else Chunk c (loop2 False cs)
Just i -> do
let prefixLength =
if i >= 1 && B.unsafeIndex c (i-1) == 13
then i-1
else i
rest =
if B.length c > i+1
then Chunk (B.drop (i+1) c) cs
else cs
result = Chunk (B.unsafeTake prefixLength c) (Empty (loop1 rest))
if i > 0 && prevCr
then Chunk (B.singleton 13) result
else result
{-# INLINABLE lines #-}
unlines :: Monad m => Stream (ByteStream m) m r -> ByteStream m r
unlines = loop where
loop str = case str of
Return r -> Empty r
Step bstr -> do
st <- bstr
cons' '\n' $ unlines st
Effect m -> Go (fmap unlines m)
{-# INLINABLE unlines #-}
words :: Monad m => ByteStream m r -> Stream (ByteStream m) m r
words = filtered . Q.splitWith w8IsSpace
where
filtered stream = case stream of
Return r -> Return r
Effect m -> Effect (fmap filtered m)
Step bs -> Effect $ bs_loop bs
bs_loop bs = case bs of
Empty r -> return $ filtered r
Go m -> m >>= bs_loop
Chunk b bs' -> if B.null b
then bs_loop bs'
else return $ Step $ Chunk b (fmap filtered bs')
{-# INLINABLE words #-}
unwords :: Monad m => Stream (ByteStream m) m r -> ByteStream m r
unwords = intercalate (singleton ' ')
{-# INLINE unwords #-}
lineSplit :: forall m r. Monad m
=> Int
-> ByteStream m r
-> Stream (ByteStream m) m r
lineSplit !n0 text0 = loop1 text0
where
n :: Int
!n = max n0 1
loop1 :: ByteStream m r -> Stream (ByteStream m) m r
loop1 text =
case text of
Empty r -> Return r
Go m -> Effect $ fmap loop1 m
Chunk c cs
| B.null c -> loop1 cs
| otherwise -> Step (loop2 0 text)
loop2 :: Int -> ByteStream m r -> ByteStream m (Stream (ByteStream m) m r)
loop2 !counter text =
case text of
Empty r -> Empty (Return r)
Go m -> Go $ fmap (loop2 counter) m
Chunk c cs ->
case nthNewLine c (n - counter) of
Left !i -> Chunk c (loop2 (counter + i) cs)
Right !l -> Chunk (B.unsafeTake l c)
$ Empty $ loop1 $! Chunk (B.unsafeDrop l c) cs
{-# INLINABLE lineSplit #-}
nthNewLine :: B.ByteString
-> Int
-> Either Int Int
nthNewLine (B.PS fp off len) targetLines =
B.accursedUnutterablePerformIO $ withForeignPtr fp $ \base ->
loop (base `plusPtr` off) targetLines 0 len
where
loop :: Ptr Word8 -> Int -> Int -> Int -> IO (Either Int Int)
loop !_ 0 !startIx !_ = return $ Right startIx
loop !p !linesNeeded !startIx !bytesLeft = do
q <- B.memchr p newline $ fromIntegral bytesLeft
if q == nullPtr
then return $ Left $! targetLines - linesNeeded
else let !pnext = q `plusPtr` 1
!skip = pnext `minusPtr` p
!snext = startIx + skip
!bytes = bytesLeft - skip
in loop pnext (linesNeeded - 1) snext bytes
newline :: Word8
newline = 10
{-# INLINE newline #-}
string :: String -> ByteStream m ()
string = chunk . B.pack . Prelude.map B.c2w
{-# INLINE string #-}
count_ :: Monad m => Char -> ByteStream m r -> m Int
count_ c = Q.count_ (c2w c)
{-# INLINE count_ #-}
count :: Monad m => Char -> ByteStream m r -> m (Of Int r)
count c = Q.count (c2w c)
{-# INLINE count #-}
putStr :: MonadIO m => ByteStream m r -> m r
putStr = hPut IO.stdout
{-# INLINE putStr #-}
putStrLn :: MonadIO m => ByteStream m r -> m r
putStrLn bs = hPut IO.stdout (snoc bs '\n')
{-# INLINE putStrLn #-}
intmaxWord, intminWord, intmaxQuot10, intmaxRem10, intminQuot10, intminRem10 :: Word
intmaxWord = fromIntegral (maxBound :: Int)
intminWord = fromIntegral (negate (minBound :: Int))
(intmaxQuot10, intmaxRem10) = intmaxWord `quotRem` 10
(intminQuot10, intminRem10) = intminWord `quotRem` 10
w8IsSpace :: Word8 -> Bool
w8IsSpace = \ !w8 ->
let w :: Word
!w = fromIntegral w8
in w .&. 0x50 == 0
&& w - 0x21 > 0x7e
&& ( w == 0x20
|| w - 0x09 < 5
|| w == 0xa0 )
{-# INLINE w8IsSpace #-}
skipSomeWS :: Monad m => ByteStream m r -> ByteStream m r
{-# INLINE skipSomeWS #-}
skipSomeWS = go 0
where
go !n (Chunk c cs)
| k <- B.dropWhile w8IsSpace c
, not $ B.null k = Chunk k cs
| n' <- n + B.length c
, n' < defaultChunkSize = go n' cs
| otherwise = cs
go !n (Go m) = Go $ go n <$> m
go _ r = r
readInt :: Monad m
=> ByteStream m r
-> m (Compose (Of (Maybe Int)) (ByteStream m) r)
{-# INLINABLE readInt #-}
readInt = start
where
nada str = return $! Compose $ Nothing :> str
start bs@(Chunk c cs)
| B.null c = start cs
| w <- B.unsafeHead c
= if | w - 0x30 <= 9 -> readDec True Nothing bs
| let rest = Chunk (B.tail c) cs
-> if | w == 0x2b -> readDec True (Just w) rest
| w == 0x2d -> readDec False (Just w) rest
| otherwise -> nada bs
start (Go m) = m >>= start
start bs@(Empty _) = nada bs
{-# INLINE readDec #-}
readDec !positive signByte = loop 0 0
where
loop !nbytes !acc = \ str -> case str of
Empty _ -> result nbytes acc str
Go m -> m >>= loop nbytes acc
Chunk c cs
| !l <- B.length c
, l > 0 -> case accumWord acc c of
(0, !_, !inrange)
| inrange
-> result nbytes acc str
| otherwise
-> overflow nbytes acc str
(!n, !a, !inrange)
| False <- inrange
-> overflow nbytes acc str
| n < l, !t <- B.drop n c
-> result (nbytes + n) a $ Chunk t cs
| a > 0 || nbytes + n < defaultChunkSize
-> loop (nbytes + n) a cs
| otherwise
-> overflow nbytes acc str
| otherwise
-> loop nbytes acc cs
accumWord acc (B.PS fp off len) =
B.accursedUnutterablePerformIO $ do
withForeignPtr fp $ \p -> do
let ptr = p `plusPtr` off
end = ptr `plusPtr` len
x@(!_, !_, !_) <- if positive
then digits intmaxQuot10 intmaxRem10 end ptr 0 acc
else digits intminQuot10 intminRem10 end ptr 0 acc
return x
where
digits !maxq !maxr !e !ptr = go ptr
where
go :: Ptr Word8 -> Int -> Word -> IO (Int, Word, Bool)
go !p !b !a | p == e = return (b, a, True)
go !p !b !a = do
!byte <- peek p
let !w = byte - 0x30
!d = fromIntegral w
if | w > 9
-> return (b, a, True)
| a < maxq
-> go (p `plusPtr` 1) (b + 1) (a * 10 + d)
| a > maxq
-> return (b, a, False)
| d <= maxr
-> go (p `plusPtr` 1) (b + 1) (a * 10 + d)
| otherwise
-> return (b, a, False)
result !nbytes !acc str
| nbytes > 0, !i <- w2int acc = return $! Compose $ Just i :> str
| otherwise = overflow nbytes acc str
w2int !n | positive = fromIntegral n
| otherwise = negate $! fromIntegral n
overflow 0 _ str = case signByte of
Nothing -> return $ Compose $ Nothing :> str
Just w -> return $ Compose $ Nothing :> Chunk (B.singleton w) str
overflow !nbytes !acc str =
let !c = overflowBytes nbytes acc
in return $! Compose $ Nothing :> Chunk c str
overflowBytes :: Int -> Word -> B.ByteString
overflowBytes !nbytes !acc =
B.unsafeCreate (nbytes + signlen) $ \p -> do
let end = p `plusPtr` (signlen - 1)
ptr = p `plusPtr` (nbytes + signlen - 1)
go end ptr acc
mapM_ (poke p) signByte
where
signlen = if signByte == Nothing then 0 else 1
go :: Ptr Word8 -> Ptr Word8 -> Word -> IO ()
go end !ptr !_ | end == ptr = return ()
go end !ptr !a = do
let (q, r) = a `quotRem` 10
poke ptr $ fromIntegral r + 0x30
go end (ptr `plusPtr` (-1)) q