{-# LANGUAGE RankNTypes, Trustworthy #-}
module Pipes.ByteString (
fromLazy
, stdin
, fromHandle
, hGetSome
, hGetNonBlocking
, hGet
, hGetRange
, hGetSomeN
, hGetN
, stdout
, toHandle
, map
, concatMap
, take
, takeWhile
, filter
, elemIndices
, findIndices
, scan
, toLazy
, toLazyM
, toLazyM'
, foldBytes
, head
, last
, null
, length
, any
, all
, maximum
, minimum
, elem
, notElem
, find
, index
, elemIndex
, findIndex
, count
, nextByte
, drawByte
, unDrawByte
, peekByte
, isEndOfBytes
, splitAt
, span
, break
, breakOn
, groupBy
, group
, word
, line
, drop
, dropWhile
, intersperse
, pack
, unpack
, chunksOf'
, chunksOf
, splitsWith
, splits
, splitOn
, groupsBy
, groups
, lines
, unlines
, words
, unwords
, module Data.ByteString
, module Data.Word
, module Pipes.Group
, module Pipes.Parse
) where
import Control.Applicative ((<*))
import Control.Exception (throwIO, try)
import Control.Monad (liftM, join)
import Control.Monad.Trans.State.Strict (modify)
import qualified Data.ByteString as BS
import Data.ByteString (ByteString)
import Data.ByteString.Internal (isSpaceWord8)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Search
import Data.ByteString.Lazy.Internal (foldrChunks, defaultChunkSize)
import Data.ByteString.Unsafe (unsafeTake)
import Data.Char (ord)
import Data.Monoid (mempty, (<>))
import Data.Functor.Constant (Constant(Constant, getConstant))
import Data.Functor.Identity (Identity)
import qualified Data.List as List
import Data.Word (Word8)
import Foreign.C.Error (Errno(Errno), ePIPE)
import qualified GHC.IO.Exception as G
import Pipes
import Pipes.Core (respond, Server')
import qualified Pipes.Group as PG
import Pipes.Group (concats, intercalates, FreeT)
import qualified Pipes.Parse as PP
import Pipes.Parse (Parser)
import qualified Pipes.Prelude as P
import qualified System.IO as IO
import Prelude hiding (
all
, any
, break
, concatMap
, drop
, dropWhile
, elem
, filter
, head
, last
, lines
, length
, map
, maximum
, minimum
, notElem
, null
, span
, splitAt
, take
, takeWhile
, unlines
, unwords
, words
)
fromLazy :: Monad m => BL.ByteString -> Producer' ByteString m ()
fromLazy bs = foldrChunks (\e a -> yield e >> a) (return ()) bs
{-# INLINABLE fromLazy #-}
stdin :: MonadIO m => Producer' ByteString m ()
stdin = fromHandle IO.stdin
{-# INLINABLE stdin #-}
fromHandle :: MonadIO m => IO.Handle -> Producer' ByteString m ()
fromHandle = hGetSome defaultChunkSize
{-# INLINABLE fromHandle #-}
hGetSome :: MonadIO m => Int -> IO.Handle -> Producer' ByteString m ()
hGetSome size h = go
where
go = do
bs <- liftIO (BS.hGetSome h size)
if (BS.null bs)
then return ()
else do
yield bs
go
{-# INLINABLE hGetSome #-}
hGetNonBlocking :: MonadIO m => Int -> IO.Handle -> Producer' ByteString m ()
hGetNonBlocking size h = go where
go = do
eof <- liftIO (IO.hIsEOF h)
if eof
then return ()
else do
bs <- liftIO (BS.hGetNonBlocking h size)
yield bs
go
{-# INLINABLE hGetNonBlocking #-}
hGet :: MonadIO m => Int -> IO.Handle -> Producer' ByteString m ()
hGet size h = go
where
go = do
bs <- liftIO (BS.hGet h size)
if (BS.null bs)
then return ()
else do
yield bs
go
{-# INLINABLE hGet #-}
hGetRange
:: MonadIO m
=> Int
-> Int
-> IO.Handle
-> Producer' ByteString m ()
hGetRange offset size h = do
liftIO $ IO.hSeek h IO.AbsoluteSeek (fromIntegral offset)
hGet size h
{-# INLINABLE hGetRange #-}
(^.) :: a -> ((b -> Constant b b) -> (a -> Constant b a)) -> b
a ^. lens = getConstant (lens Constant a)
hGetSomeN :: MonadIO m => IO.Handle -> Int -> Server' Int ByteString m ()
hGetSomeN h = go
where
go size = do
bs <- liftIO (BS.hGetSome h size)
if (BS.null bs)
then return ()
else do
size2 <- respond bs
go size2
{-# INLINABLE hGetSomeN #-}
hGetN :: MonadIO m => IO.Handle -> Int -> Server' Int ByteString m ()
hGetN h = go
where
go size = do
bs <- liftIO (BS.hGet h size)
if (BS.null bs)
then return ()
else do
size2 <- respond bs
go size2
{-# INLINABLE hGetN #-}
stdout :: MonadIO m => Consumer' ByteString m ()
stdout = go
where
go = do
bs <- await
x <- liftIO $ try (BS.putStr bs)
case x of
Left (G.IOError { G.ioe_type = G.ResourceVanished
, G.ioe_errno = Just ioe })
| Errno ioe == ePIPE
-> return ()
Left e -> liftIO (throwIO e)
Right () -> go
{-# INLINABLE stdout #-}
toHandle :: MonadIO m => IO.Handle -> Consumer' ByteString m r
toHandle h = for cat (liftIO . BS.hPut h)
{-# INLINABLE [1] toHandle #-}
{-# RULES "p >-> toHandle h" forall p h .
p >-> toHandle h = for p (\bs -> liftIO (BS.hPut h bs))
#-}
map :: Monad m => (Word8 -> Word8) -> Pipe ByteString ByteString m r
map f = P.map (BS.map f)
{-# INLINE map #-}
concatMap :: Monad m => (Word8 -> ByteString) -> Pipe ByteString ByteString m r
concatMap f = P.map (BS.concatMap f)
{-# INLINABLE concatMap #-}
take :: (Monad m, Integral n) => n -> Pipe ByteString ByteString m ()
take n0 = go n0 where
go n
| n <= 0 = return ()
| otherwise = do
bs <- await
let len = fromIntegral (BS.length bs)
if (len > n)
then yield (unsafeTake (fromIntegral n) bs)
else do
yield bs
go (n - len)
{-# INLINABLE take #-}
takeWhile :: Monad m => (Word8 -> Bool) -> Pipe ByteString ByteString m ()
takeWhile predicate = go
where
go = do
bs <- await
let (prefix, suffix) = BS.span predicate bs
if (BS.null suffix)
then do
yield bs
go
else yield prefix
{-# INLINABLE takeWhile #-}
filter :: Monad m => (Word8 -> Bool) -> Pipe ByteString ByteString m r
filter predicate = P.map (BS.filter predicate)
{-# INLINABLE filter #-}
elemIndices :: (Monad m, Num n) => Word8 -> Pipe ByteString n m r
elemIndices w8 = findIndices (w8 ==)
{-# INLINABLE elemIndices #-}
findIndices :: (Monad m, Num n) => (Word8 -> Bool) -> Pipe ByteString n m r
findIndices predicate = go 0
where
go n = do
bs <- await
each $ List.map (\i -> n + fromIntegral i) (BS.findIndices predicate bs)
go $! n + fromIntegral (BS.length bs)
{-# INLINABLE findIndices #-}
scan
:: Monad m
=> (Word8 -> Word8 -> Word8) -> Word8 -> Pipe ByteString ByteString m r
scan step begin = do
yield (BS.singleton begin)
go begin
where
go w8 = do
bs <- await
let bs' = BS.scanl step w8 bs
w8' = BS.last bs'
yield (BS.tail bs')
go w8'
{-# INLINABLE scan #-}
toLazy :: Producer ByteString Identity () -> BL.ByteString
toLazy = BL.fromChunks . P.toList
{-# INLINABLE toLazy #-}
toLazyM :: Monad m => Producer ByteString m () -> m BL.ByteString
toLazyM = liftM BL.fromChunks . P.toListM
{-# INLINABLE toLazyM #-}
toLazyM' :: Monad m => Producer ByteString m a -> m (BL.ByteString, a)
toLazyM' p = do (chunks, a) <- P.toListM' p
return (BL.fromChunks chunks, a)
{-# INLINABLE toLazyM' #-}
foldBytes
:: Monad m
=> (x -> Word8 -> x) -> x -> (x -> r) -> Producer ByteString m () -> m r
foldBytes step begin done = P.fold (\x bs -> BS.foldl' step x bs) begin done
{-# INLINABLE foldBytes #-}
head :: Monad m => Producer ByteString m () -> m (Maybe Word8)
head = go
where
go p = do
x <- nextByte p
return $ case x of
Left _ -> Nothing
Right (w8, _) -> Just w8
{-# INLINABLE head #-}
last :: Monad m => Producer ByteString m () -> m (Maybe Word8)
last = go Nothing
where
go r p = do
x <- next p
case x of
Left () -> return r
Right (bs, p') ->
go (if BS.null bs then r else (Just $ BS.last bs)) p'
{-# INLINABLE last #-}
null :: Monad m => Producer ByteString m () -> m Bool
null = P.all BS.null
{-# INLINABLE null #-}
length :: (Monad m, Num n) => Producer ByteString m () -> m n
length = P.fold (\n bs -> n + fromIntegral (BS.length bs)) 0 id
{-# INLINABLE length #-}
any :: Monad m => (Word8 -> Bool) -> Producer ByteString m () -> m Bool
any predicate = P.any (BS.any predicate)
{-# INLINABLE any #-}
all :: Monad m => (Word8 -> Bool) -> Producer ByteString m () -> m Bool
all predicate = P.all (BS.all predicate)
{-# INLINABLE all #-}
maximum :: Monad m => Producer ByteString m () -> m (Maybe Word8)
maximum = P.fold step Nothing id
where
step mw8 bs =
if (BS.null bs)
then mw8
else Just $ case mw8 of
Nothing -> BS.maximum bs
Just w8 -> max w8 (BS.maximum bs)
{-# INLINABLE maximum #-}
minimum :: Monad m => Producer ByteString m () -> m (Maybe Word8)
minimum = P.fold step Nothing id
where
step mw8 bs =
if (BS.null bs)
then mw8
else case mw8 of
Nothing -> Just (BS.minimum bs)
Just w8 -> Just (min w8 (BS.minimum bs))
{-# INLINABLE minimum #-}
elem :: Monad m => Word8 -> Producer ByteString m () -> m Bool
elem w8 = P.any (BS.elem w8)
{-# INLINABLE elem #-}
notElem :: Monad m => Word8 -> Producer ByteString m () -> m Bool
notElem w8 = P.all (BS.notElem w8)
{-# INLINABLE notElem #-}
find
:: Monad m
=> (Word8 -> Bool) -> Producer ByteString m () -> m (Maybe Word8)
find predicate p = head (p >-> filter predicate)
{-# INLINABLE find #-}
index
:: (Monad m, Integral n)
=> n -> Producer ByteString m () -> m (Maybe Word8)
index n p = head (drop n p)
{-# INLINABLE index #-}
elemIndex
:: (Monad m, Num n) => Word8 -> Producer ByteString m () -> m (Maybe n)
elemIndex w8 = findIndex (w8 ==)
{-# INLINABLE elemIndex #-}
findIndex
:: (Monad m, Num n)
=> (Word8 -> Bool) -> Producer ByteString m () -> m (Maybe n)
findIndex predicate p = P.head (p >-> findIndices predicate)
{-# INLINABLE findIndex #-}
count :: (Monad m, Num n) => Word8 -> Producer ByteString m () -> m n
count w8 p = P.fold (+) 0 id (p >-> P.map (fromIntegral . BS.count w8))
{-# INLINABLE count #-}
nextByte
:: Monad m
=> Producer ByteString m r
-> m (Either r (Word8, Producer ByteString m r))
nextByte = go
where
go p = do
x <- next p
case x of
Left r -> return (Left r)
Right (bs, p') -> case (BS.uncons bs) of
Nothing -> go p'
Just (w8, bs') -> return (Right (w8, yield bs' >> p'))
{-# INLINABLE nextByte #-}
drawByte :: Monad m => Parser ByteString m (Maybe Word8)
drawByte = do
x <- PP.draw
case x of
Nothing -> return Nothing
Just bs -> case (BS.uncons bs) of
Nothing -> drawByte
Just (w8, bs') -> do
PP.unDraw bs'
return (Just w8)
{-# INLINABLE drawByte #-}
unDrawByte :: Monad m => Word8 -> Parser ByteString m ()
unDrawByte w8 = modify (yield (BS.singleton w8) >>)
{-# INLINABLE unDrawByte #-}
peekByte :: Monad m => Parser ByteString m (Maybe Word8)
peekByte = do
x <- drawByte
case x of
Nothing -> return ()
Just w8 -> unDrawByte w8
return x
{-# INLINABLE peekByte #-}
isEndOfBytes :: Monad m => Parser ByteString m Bool
isEndOfBytes = do
x <- peekByte
return (case x of
Nothing -> True
Just _ -> False )
{-# INLINABLE isEndOfBytes #-}
type Lens' a b = forall f . Functor f => (b -> f b) -> (a -> f a)
splitAt
:: (Monad m, Integral n)
=> n
-> Lens' (Producer ByteString m x)
(Producer ByteString m (Producer ByteString m x))
splitAt n0 k p0 = fmap join (k (go n0 p0))
where
go n p =
if (n <= 0)
then return p
else do
x <- lift (next p)
case x of
Left r -> return (return r)
Right (bs, p') -> do
let len = fromIntegral (BS.length bs)
if (len <= n)
then do
yield bs
go (n - len) p'
else do
let (prefix, suffix) =
BS.splitAt (fromIntegral n) bs
yield prefix
return (yield suffix >> p')
{-# INLINABLE splitAt #-}
span
:: Monad m
=> (Word8 -> Bool)
-> Lens' (Producer ByteString m x)
(Producer ByteString m (Producer ByteString m x))
span predicate k p0 = fmap join (k (go p0))
where
go p = do
x <- lift (next p)
case x of
Left r -> return (return r)
Right (bs, p') -> do
let (prefix, suffix) = BS.span predicate bs
if (BS.null suffix)
then do
yield bs
go p'
else do
yield prefix
return (yield suffix >> p')
{-# INLINABLE span #-}
break
:: Monad m
=> (Word8 -> Bool)
-> Lens' (Producer ByteString m x)
(Producer ByteString m (Producer ByteString m x))
break predicate = span (not . predicate)
{-# INLINABLE break #-}
breakOn
:: Monad m
=> ByteString
-> Lens' (Producer ByteString m x)
(Producer ByteString m (Producer ByteString m x))
breakOn needle k p0 =
fmap join (k (go mempty p0))
where
len0 = BS.length needle
go leftovers p =
if BS.length leftovers < len0
then do
x <- lift (next p)
case x of
Left r -> do
yield leftovers
return (return r)
Right (bytes, p') -> do
go (leftovers <> bytes) p'
else do
let (prefix, suffix) = Data.ByteString.Search.breakOn needle leftovers
if BS.null suffix
then do
let len = BS.length leftovers
let (output, leftovers') =
BS.splitAt (len + 1 - len0) leftovers
yield output
go leftovers' p
else do
yield prefix
return (yield suffix >> p)
{-# INLINABLE breakOn #-}
groupBy
:: Monad m
=> (Word8 -> Word8 -> Bool)
-> Lens' (Producer ByteString m x)
(Producer ByteString m (Producer ByteString m x))
groupBy equals k p0 = fmap join (k (_groupBy p0))
where
_groupBy p = do
x <- lift (next p)
case x of
Left r -> return (return r)
Right (bs, p') -> case (BS.uncons bs) of
Nothing -> _groupBy p'
Just (w8, _) -> (yield bs >> p')^.span (equals w8)
{-# INLINABLE groupBy #-}
group
:: Monad m
=> Lens' (Producer ByteString m x)
(Producer ByteString m (Producer ByteString m x))
group = groupBy (==)
{-# INLINABLE group #-}
word
:: Monad m
=> Lens' (Producer ByteString m x)
(Producer ByteString m (Producer ByteString m x))
word k p0 = fmap join (k (to p0))
where
to p = do
p' <- p^.span isSpaceWord8
p'^.break isSpaceWord8
{-# INLINABLE word #-}
nl :: Word8
nl = fromIntegral (ord '\n')
line
:: Monad m
=> Lens' (Producer ByteString m x)
(Producer ByteString m (Producer ByteString m x))
line = break (== nl)
{-# INLINABLE line #-}
drop
:: (Monad m, Integral n)
=> n -> Producer ByteString m r -> Producer ByteString m r
drop n p = do
p' <- lift $ runEffect (for (p ^. splitAt n) discard)
p'
{-# INLINABLE drop #-}
dropWhile
:: Monad m
=> (Word8 -> Bool) -> Producer ByteString m r -> Producer ByteString m r
dropWhile predicate p = do
p' <- lift $ runEffect (for (p ^. span predicate) discard)
p'
{-# INLINABLE dropWhile #-}
intersperse
:: Monad m => Word8 -> Producer ByteString m r -> Producer ByteString m r
intersperse w8 = go0
where
go0 p = do
x <- lift (next p)
case x of
Left r -> return r
Right (bs, p') -> do
yield (BS.intersperse w8 bs)
go1 p'
go1 p = do
x <- lift (next p)
case x of
Left r -> return r
Right (bs, p') -> do
yield (BS.singleton w8)
yield (BS.intersperse w8 bs)
go1 p'
{-# INLINABLE intersperse #-}
pack :: Monad m => Lens' (Producer Word8 m x) (Producer ByteString m x)
pack k p = fmap _unpack (k (_pack p))
{-# INLINABLE pack #-}
unpack :: Monad m => Lens' (Producer ByteString m x) (Producer Word8 m x)
unpack k p = fmap _pack (k (_unpack p))
{-# INLINABLE unpack #-}
_pack :: Monad m => Producer Word8 m x -> Producer ByteString m x
_pack p = PG.folds step id done (p^.PG.chunksOf defaultChunkSize)
where
step diffAs w8 = diffAs . (w8:)
done diffAs = BS.pack (diffAs [])
{-# INLINABLE _pack #-}
_unpack :: Monad m => Producer ByteString m x -> Producer Word8 m x
_unpack p = for p (each . BS.unpack)
{-# INLINABLE _unpack #-}
chunksOf'
:: (Monad m, Integral n)
=> n -> Producer ByteString m r -> Producer ByteString m r
chunksOf' n p =
PG.folds
(\diffBs bs -> diffBs . (bs:))
id
(\diffBs -> BS.concat (diffBs []))
(p ^. chunksOf n)
{-# INLINABLE chunksOf' #-}
chunksOf
:: (Monad m, Integral n)
=> n -> Lens' (Producer ByteString m x) (FreeT (Producer ByteString m) m x)
chunksOf n k p0 = fmap concats (k (go p0))
where
go p = PG.FreeT $ do
x <- next p
return $ case x of
Left r -> PG.Pure r
Right (bs, p') -> PG.Free $ do
p'' <- (yield bs >> p')^.splitAt n
return (go p'')
{-# INLINABLE chunksOf #-}
splitsWith
:: Monad m
=> (Word8 -> Bool)
-> Producer ByteString m x -> FreeT (Producer ByteString m) m x
splitsWith predicate p0 = PG.FreeT (go0 p0)
where
go0 p = do
x <- next p
case x of
Left r -> return (PG.Pure r)
Right (bs, p') ->
if (BS.null bs)
then go0 p'
else go1 (yield bs >> p')
go1 p = return $ PG.Free $ do
p' <- p^.break predicate
return $ PG.FreeT $ do
x <- nextByte p'
case x of
Left r -> return (PG.Pure r)
Right (_, p'') -> go1 p''
{-# INLINABLE splitsWith #-}
splits
:: Monad m
=> Word8
-> Lens' (Producer ByteString m x) (FreeT (Producer ByteString m) m x)
splits w8 k p =
fmap (PG.intercalates (yield (BS.singleton w8))) (k (splitsWith (w8 ==) p))
{-# INLINABLE splits #-}
splitOn
:: Monad m
=> ByteString
-> Lens' (Producer ByteString m x) (FreeT (Producer ByteString m) m x)
splitOn needle k p0 =
fmap
(PG.intercalates (yield needle))
(k (go p0))
where
len0 = BS.length needle
go p = PG.FreeT $ do
x <- next p
return $ case x of
Left r -> PG.Pure r
Right (bs, p') -> PG.Free $ do
p'' <- (yield bs >> p')^.(breakOn needle)
return (go (drop len0 p''))
{-# INLINABLE splitOn #-}
groupsBy
:: Monad m
=> (Word8 -> Word8 -> Bool)
-> Lens' (Producer ByteString m x) (FreeT (Producer ByteString m) m x)
groupsBy equals k p0 = fmap concats (k (_groupsBy p0))
where
_groupsBy p0' = PG.FreeT (go p0')
where
go p = do
x <- next p
case x of
Left r -> return (PG.Pure r)
Right (bs, p') -> case (BS.uncons bs) of
Nothing -> go p'
Just (w8, _) -> do
return $ PG.Free $ do
p'' <- (yield bs >> p')^.span (equals w8)
return $ PG.FreeT (go p'')
{-# INLINABLE groupsBy #-}
groups
:: Monad m
=> Lens' (Producer ByteString m x) (FreeT (Producer ByteString m) m x)
groups = groupsBy (==)
{-# INLINABLE groups #-}
lines
:: Monad m
=> Lens' (Producer ByteString m x) (FreeT (Producer ByteString m) m x)
lines k p = fmap _unlines (k (_lines p))
{-# INLINABLE lines #-}
unlines
:: Monad m
=> Lens' (FreeT (Producer ByteString m) m x) (Producer ByteString m x)
unlines k p = fmap _lines (k (_unlines p))
{-# INLINABLE unlines #-}
_lines
:: Monad m => Producer ByteString m x -> FreeT (Producer ByteString m) m x
_lines p0 = PG.FreeT (go0 p0)
where
go0 p = do
x <- next p
case x of
Left r -> return (PG.Pure r)
Right (bs, p') ->
if (BS.null bs)
then go0 p'
else return $ PG.Free $ go1 (yield bs >> p')
go1 p = do
p' <- p^.line
return $ PG.FreeT $ do
x <- nextByte p'
case x of
Left r -> return (PG.Pure r)
Right (_, p'') -> go0 p''
{-# INLINABLE _lines #-}
_unlines
:: Monad m => FreeT (Producer ByteString m) m x -> Producer ByteString m x
_unlines = concats . PG.maps addNewline
where
addNewline p = p <* yield (BS.singleton nl)
{-# INLINABLE _unlines #-}
words :: Monad m => Producer ByteString m x -> FreeT (Producer ByteString m) m x
words p = PG.FreeT $ do
x <- next (dropWhile isSpaceWord8 p)
return $ case x of
Left r -> PG.Pure r
Right (bs, p') -> PG.Free $ do
p'' <- (yield bs >> p')^.break isSpaceWord8
return (words p'')
{-# INLINABLE words #-}
unwords
:: Monad m => FreeT (Producer ByteString m) m x -> Producer ByteString m x
unwords = PG.intercalates (yield $ BS.singleton $ fromIntegral $ ord ' ')
{-# INLINABLE unwords #-}