diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +IOStreams Contributors: + + - Gregory Collins + - Gabriel Gonzalez + +------------------------------------------------------------------------------ +Contains some code ported from the "blaze-builder-enumerator" package by Simon +Meier and Thomas Sutton, distributed under the following license: + +Copyright 2010, Thomas Sutton. All rights reserved. +Copyright 2011, Simon Meier. All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +* The names of its contributors may not be used to endorse or promote products +derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ''AS IS'' AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2012, Google, Inc. +Copyright (c) 2012, Erudify AG + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright notice, this +list of conditions and the following disclaimer in the documentation and/or +other materials provided with the distribution. + +Neither the names of Google, Erudify, nor the names of other contributors may +be used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,22 @@ +The io-streams library contains simple and easy to use primitives for I/O +using streams. Based on simple types with one type parameter (`InputStream a` +and `OutputStream a`), io-streams provides a basic interface to +side-effecting input and output in `IO` monad with the following +features: + + * three fundamental I/O primitives that anyone can understand: `read :: + InputStream a -> IO (Maybe a)`, `unRead :: a -> InputStream a -> IO ()`, + and `write :: Maybe a -> OutputStream a -> IO ()`. + + * simple types and side-effecting IO operations mean straightforward and + simple exception handling and resource cleanup using standard Haskell + facilities like `bracket`. + + * code to transform files, handles, and sockets to streams + + * a variety of combinators for wrapping and transforming streams, including + compression and decompression using zlib, controlling precisely how many + bytes are read to or written from a socket, buffering output using + `blaze-builder`, etc. + + * support for parsing from streams using `attoparsec`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/io-streams.cabal b/io-streams.cabal new file mode 100644 --- /dev/null +++ b/io-streams.cabal @@ -0,0 +1,218 @@ +Name: io-streams +Version: 1.0.0.0 +License: BSD3 +License-file: LICENSE +Category: Data, Network, IO-Streams +Build-type: Simple +Maintainer: Gregory Collins +Cabal-version: >= 1.10 +Synopsis: Simple, composable, and easy-to-use stream I/O +Tested-With: GHC==7.6.2, GHC==7.6.1, GHC==7.4.2, GHC==7.4.1, + GHC==7.2.2, GHC==7.0.4 +Description: + /Overview/ + . + The io-streams library contains simple and easy-to-use primitives for I/O + using streams. Most users will want to import the top-level convenience + module "System.IO.Streams", which re-exports most of the library: + . + @ + import "System.IO.Streams" (InputStream, OutputStream) + import qualified "System.IO.Streams" as Streams + @ + . + For first-time users, @io-streams@ comes with an included tutorial, which can + be found in the "System.IO.Streams.Tutorial" module. + . + /Features/ + . + The @io-streams@ user API has two basic types: @InputStream a@ and + @OutputStream a@, and three fundamental I/O primitives: + . + @ + \-\- read an item from an input stream + Streams.'System.IO.Streams.read' :: 'System.IO.Streams.InputStream' a -> IO (Maybe a) + . + \-\- push an item back to an input stream + Streams.'System.IO.Streams.unRead' :: a -> 'System.IO.Streams.InputStream' a -> IO () + . + \-\- write to an output stream + Streams.'System.IO.Streams.write' :: Maybe a -> 'System.IO.Streams.OutputStream' a -> IO () + @ + . + Streams can be transformed by composition and hooked together with provided combinators: + . + @ + ghci> Streams.fromList [1,2,3::Int] >>= Streams.map (*10) >>= Streams.toList + [10,20,30] + @ + . + Stream composition leaves the original stream accessible: + . + @ + ghci> input \<- Streams.fromByteString \"long string\" + ghci> wrapped \<- Streams.takeBytes 4 input + ghci> read wrapped + Just \"long\" + ghci> read wrapped + Nothing + ghci> read input + Just \" string\" + @ + . + Simple types and operations in the IO monad mean straightforward and simple + exception handling and resource cleanup using Haskell standard library + facilities like 'Control.Exception.bracket'. + . + @io-streams@ comes with: + . + * functions to use files, handles, concurrent channels, sockets, lists, + vectors, and more as streams. + . + * a variety of combinators for wrapping and transforming streams, including + compression and decompression using zlib, controlling precisely how many + bytes are read from or written to a stream, buffering output using + bytestring builders, folds, maps, filters, zips, etc. + . + * support for parsing from streams using @attoparsec@. + +Extra-Source-Files: CONTRIBUTORS README.md + +------------------------------------------------------------------------------ +Library + hs-source-dirs: src + Default-language: Haskell2010 + + ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-unused-do-bind + + ghc-prof-options: -prof -auto-all + + Exposed-modules: System.IO.Streams, + System.IO.Streams.Attoparsec, + System.IO.Streams.Builder, + System.IO.Streams.ByteString, + System.IO.Streams.Combinators, + System.IO.Streams.Concurrent, + System.IO.Streams.Core, + System.IO.Streams.Debug, + System.IO.Streams.Handle, + System.IO.Streams.File, + System.IO.Streams.List, + System.IO.Streams.Network, + System.IO.Streams.Text, + System.IO.Streams.Vector, + System.IO.Streams.Zlib, + System.IO.Streams.Internal, + System.IO.Streams.Tutorial + + Other-modules: System.IO.Streams.Internal.Attoparsec, + System.IO.Streams.Internal.Search + + Build-depends: base >= 4 && <5, + attoparsec >= 0.10 && <0.11, + blaze-builder >= 0.3.1 && <0.4, + bytestring >= 0.9 && <0.11, + network >= 2.4 && <2.5, + primitive >= 0.2 && <0.6, + text >= 0.10 && <0.12, + time >= 1.2 && <1.5, + transformers >= 0.2 && <0.4, + vector >= 0.7 && <0.11, + zlib-bindings >= 0.1 && <0.2 + + if impl(ghc >= 7.2) + other-extensions: Trustworthy + + other-extensions: + BangPatterns, + CPP, + DeriveDataTypeable, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses, + OverloadedStrings, + RankNTypes + +------------------------------------------------------------------------------ +Test-suite testsuite + Type: exitcode-stdio-1.0 + hs-source-dirs: src test + Main-is: TestSuite.hs + Default-language: Haskell2010 + + Other-modules: System.IO.Streams.Tests.Attoparsec, + System.IO.Streams.Tests.Builder, + System.IO.Streams.Tests.ByteString, + System.IO.Streams.Tests.Combinators, + System.IO.Streams.Tests.Common, + System.IO.Streams.Tests.Debug, + System.IO.Streams.Tests.File, + System.IO.Streams.Tests.Handle, + System.IO.Streams.Tests.Internal, + System.IO.Streams.Tests.List, + System.IO.Streams.Tests.Network, + System.IO.Streams.Tests.Text, + System.IO.Streams.Tests.Vector, + System.IO.Streams.Tests.Zlib, + System.IO.Streams, + System.IO.Streams.Attoparsec, + System.IO.Streams.Builder, + System.IO.Streams.ByteString, + System.IO.Streams.Combinators, + System.IO.Streams.Concurrent, + System.IO.Streams.Core, + System.IO.Streams.Debug, + System.IO.Streams.Handle, + System.IO.Streams.File, + System.IO.Streams.List, + System.IO.Streams.Network, + System.IO.Streams.Text, + System.IO.Streams.Vector, + System.IO.Streams.Zlib, + System.IO.Streams.Internal, + System.IO.Streams.Internal.Attoparsec, + System.IO.Streams.Internal.Search + + + ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded + -fno-warn-unused-do-bind + ghc-prof-options: -prof -auto-all + + Build-depends: base >= 4 && <5, + attoparsec >= 0.10 && <0.11, + blaze-builder >= 0.3.1 && <0.4, + bytestring >= 0.9 && <0.11, + deepseq >= 1.2 && <1.4, + directory >= 1.1 && <2, + filepath >= 1.2 && <2, + mtl >= 2 && <3, + network >= 2.4 && <2.5, + primitive >= 0.2 && <0.5, + text >= 0.10 && <0.12, + time >= 1.2 && <1.5, + transformers >= 0.2 && <0.4, + vector >= 0.7 && <0.11, + zlib-bindings >= 0.1 && <0.2, + + HUnit >= 1.2 && <2, + QuickCheck >= 2.3.0.2 && <3, + test-framework >= 0.6 && <0.7, + test-framework-hunit >= 0.2.7 && <0.3, + test-framework-quickcheck2 >= 0.2.12.1 && <0.3, + zlib >= 0.5 && <0.6 + + if impl(ghc >= 7.2) + other-extensions: Trustworthy + + other-extensions: + BangPatterns, + CPP, + DeriveDataTypeable, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses, + OverloadedStrings, + RankNTypes + +source-repository head + type: git + location: git://github.com/snapframework/io-streams.git diff --git a/src/System/IO/Streams.hs b/src/System/IO/Streams.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | This module is a top-level convenience module which re-exports most of the +-- @io-streams@ library. +-- +-- It is recommended to import this module qualified, as follows: +-- +-- @ +-- import "System.IO.Streams" ('Generator', 'InputStream', 'OutputStream') +-- import qualified "System.IO.Streams" as Streams +-- @ +-- +-- For an in-depth tutorial on how to use @io-streams@, please see the +-- "System.IO.Streams.Tutorial" module. +-- +-- Is there a function missing from this library? Interested in contributing? +-- Send a pull request to . +module System.IO.Streams + ( -- * Stream types + InputStream + , OutputStream + + + -- ** A note about resource acquisition\/release semantics + -- $resource + + -- * Creating streams + , makeInputStream + , makeOutputStream + + -- * Primitive stream operations + , read + , unRead + , peek + , write + , atEOF + + -- * Connecting streams together + , connect + , connectTo + , supply + , supplyTo + , appendInputStream + , concatInputStreams + + -- * Thread safety \/ concurrency + , lockingInputStream + , lockingOutputStream + + -- * Utility streams + , nullInput + , nullOutput + + -- * Generator monad + -- $generator + , Generator + , fromGenerator + , yield + + -- * Batteries included + , module System.IO.Streams.Builder + , module System.IO.Streams.ByteString + , module System.IO.Streams.Combinators + , module System.IO.Streams.Handle + , module System.IO.Streams.File + , module System.IO.Streams.List + , module System.IO.Streams.Network + , module System.IO.Streams.Text + , module System.IO.Streams.Vector + , module System.IO.Streams.Zlib + ) where + +------------------------------------------------------------------------------ +import Prelude () + +------------------------------------------------------------------------------ +import System.IO.Streams.Internal + +import System.IO.Streams.Builder +import System.IO.Streams.ByteString +import System.IO.Streams.Combinators +import System.IO.Streams.File +import System.IO.Streams.Handle +import System.IO.Streams.List +import System.IO.Streams.Network +import System.IO.Streams.Text +import System.IO.Streams.Vector +import System.IO.Streams.Zlib + +------------------------------------------------------------------------------ +-- $generator +-- #generator# +-- +-- The 'Generator' monad makes it easier for you to define more complicated +-- 'InputStream's. Generators have a couple of basic features: +-- +-- 'Generator' is a 'MonadIO', so you can run IO actions from within it using +-- 'liftIO': +-- +-- @ +-- foo :: 'Generator' r a +-- foo = 'liftIO' fireTheMissiles +-- @ +-- +-- 'Generator' has a 'yield' function: +-- +-- @ +-- 'yield' :: r -> 'Generator' r () +-- @ +-- +-- A call to \"'yield' @x@\" causes \"'Just' @x@\" to appear when reading the +-- 'InputStream'. Finally, 'Generator' comes with a function to turn a +-- 'Generator' into an 'InputStream': +-- +-- @ +-- 'fromGenerator' :: 'Generator' r a -> 'IO' ('InputStream' r) +-- @ +-- +-- Once the 'Generator' action finishes, 'fromGenerator' will cause an +-- end-of-stream 'Nothing' marker to appear at the output. Example: +-- +-- @ +-- ghci> (Streams.'fromGenerator' $ 'Control.Monad.sequence' $ 'Prelude.map' Streams.'yield' [1..5::Int]) >>= Streams.'toList' +-- [1,2,3,4,5] +-- @ + + +------------------------------------------------------------------------------ +-- $resource +-- #resource# +-- +-- In general, the convention within this library is that input and output +-- streams do not deal with resource acquisition\/release semantics, with rare +-- exceptions like 'System.IO.Streams.withFileAsInput'. For example, sending +-- \"end-of-stream\" to an 'OutputStream' wrapped around a 'System.IO.Handle' +-- doesn't cause the handle to be closed. You can think of streams as little +-- state machines that are attached to the underlying resources, and the +-- finalization\/release of these resources is up to you. +-- +-- This means that you can use standard Haskell idioms like +-- 'Control.Exception.bracket' to handle resource acquisition and cleanup in an +-- exception-safe way. +-- + diff --git a/src/System/IO/Streams/Attoparsec.hs b/src/System/IO/Streams/Attoparsec.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Attoparsec.hs @@ -0,0 +1,11 @@ +-- | This module provides support for parsing values from 'InputStream's using +-- @attoparsec@. + +module System.IO.Streams.Attoparsec + ( -- * Parsing + parseFromStream + , parserToInputStream + , ParseException(..) + ) where + +import System.IO.Streams.Internal.Attoparsec diff --git a/src/System/IO/Streams/Builder.hs b/src/System/IO/Streams/Builder.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Builder.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Buffering for output streams based on bytestring builders. +-- +-- Buffering an output stream can often improve throughput by reducing the +-- number of system calls made through the file descriptor. The @blaze-builder@ +-- package provides an efficient set of primitives for serializing values +-- directly to an output buffer. +-- +-- (/N.B./: most of the @blaze-builder@ package has been moved into +-- @bytestring@ in versions \>= 0.10; once two or three Haskell Platform +-- editions have been released that contain @bytestring@ 0.10 or higher, the +-- dependency on @blaze-builder@ will be dropped in favor of the native support +-- for 'Builder' contained in the @bytestring@ package.) +-- +-- /Using this module/ +-- +-- Given an 'OutputStream' taking 'ByteString': +-- +-- > someOutputStream :: OutputStream ByteString +-- +-- You create a new output stream wrapping the original one that accepts +-- 'Builder' values: +-- +-- +-- @ +-- do +-- newStream <- Streams.'builderStream' someOutputStream +-- Streams.'write' ('Just' $ 'Blaze.ByteString.Builder.fromByteString' \"hello\") newStream +-- .... +-- @ +-- +-- +-- You can flush the output buffer using 'Blaze.ByteString.Builder.flush': +-- +-- @ +-- .... +-- Streams.'write' ('Just' 'Blaze.ByteString.Builder.flush') newStream +-- .... +-- @ +-- +-- As a convention, 'builderStream' will write the empty string to the wrapped +-- 'OutputStream' upon a builder buffer flush. Output streams which receive +-- 'ByteString' should either ignore the empty string or interpret it as a +-- signal to flush their own buffers, as the "System.IO.Streams.Zlib" functions +-- do. +-- +-- /Example/ +-- +-- @ +-- example :: IO [ByteString] +-- example = do +-- let l1 = 'Data.List.intersperse' \" \" [\"the\", \"quick\", \"brown\", \"fox\"] +-- let l2 = 'Data.List.intersperse' \" \" [\"jumped\", \"over\", \"the\"] +-- let l = map 'Blaze.ByteString.Builder.fromByteString' l1 ++ ['Blaze.ByteString.Builder.flush'] ++ map 'Blaze.ByteString.Builder.fromByteString' l2 +-- is \<- Streams.'System.IO.Streams.fromList' l +-- (os0, grab) \<- Streams.'System.IO.Streams.listOutputStream' +-- os \<- Streams.'builderStream' os0 +-- Streams.'System.IO.Streams.connect' is os >> grab +-- +-- ghci> example +-- [\"the quick brown fox\",\"\",\"jumped over the\"] +-- @ +-- +module System.IO.Streams.Builder + ( -- * Blaze builder conversion + builderStream + , unsafeBuilderStream + , builderStreamWith + ) where + +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder.Internal (defaultBufferSize) +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder.Internal.Types (BufRange (..), + BuildSignal (..), + Builder (..), + buildStep) +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder.Internal.Buffer (Buffer, BufferAllocStrategy, allNewBuffersStrategy, + execBuildStep, reuseBufferStrategy, + unsafeFreezeBuffer, unsafeFreezeNonEmptyBuffer, + updateEndOfSlice) +------------------------------------------------------------------------------ +import Control.Monad (when) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +------------------------------------------------------------------------------ +import System.IO.Streams.Internal (OutputStream, + Sink (..), + nullSink, + sinkToStream, + write) + + +------------------------------------------------------------------------------ +-- | Converts a 'ByteString' sink into a 'Builder' sink. +-- +-- Note that if the generated builder receives a +-- 'Blaze.ByteString.Builder.flush', by convention it will send an empty string +-- to the supplied @'OutputStream' 'ByteString'@ to indicate that any output +-- buffers are to be flushed. +-- +builderStream :: OutputStream ByteString -> IO (OutputStream Builder) +builderStream = builderStreamWith (allNewBuffersStrategy defaultBufferSize) + + +------------------------------------------------------------------------------ +-- | Unsafe variation on 'builderStream' that reuses an existing buffer for +-- efficiency. +-- +-- /NOTE/: because the buffer is reused, subsequent 'ByteString' values written +-- to the wrapped 'OutputString' will cause previous yielded strings to change. +-- Do not retain references to these 'ByteString' values inside the +-- 'OutputStream' you pass to this function, or you will violate referential +-- transparency. +-- +-- If you /must/ retain copies of these values, then please use +-- 'Data.ByteString.copy' to ensure that you have a fresh copy of the +-- underlying string. +-- +-- You can create a Buffer with +-- 'Blaze.ByteString.Builder.Internal.Buffer.allocBuffer'. +-- +-- +unsafeBuilderStream :: IO Buffer + -> OutputStream ByteString + -> IO (OutputStream Builder) +unsafeBuilderStream = builderStreamWith . reuseBufferStrategy + + +------------------------------------------------------------------------------ +-- | A customized version of 'builderStream', using the specified +-- 'BufferAllocStrategy'. +builderStreamWith :: BufferAllocStrategy + -> OutputStream ByteString + -> IO (OutputStream Builder) +builderStreamWith (ioBuf0, nextBuf) os = do + sinkToStream (sink ioBuf0) + where + sink ioBuf = Sink $ maybe eof chunk + where + eof = do + buf <- ioBuf + case unsafeFreezeNonEmptyBuffer buf of + Nothing -> write Nothing os + x@(Just s) -> do + when (not $ S.null s) $ write x os + write Nothing os + + return nullSink + + chunk c = feed (unBuilder c (buildStep finalStep)) ioBuf + + + finalStep !(BufRange pf _) = return $! Done pf $! () + + feed bStep ioBuf = do + !buf <- ioBuf + signal <- execBuildStep bStep buf + + case signal of + Done op' _ -> return $ sink (return (updateEndOfSlice buf op')) + + BufferFull minSize op' bStep' -> do + let buf' = updateEndOfSlice buf op' + {-# INLINE cont #-} + cont = do + ioBuf' <- nextBuf minSize buf' + feed bStep' ioBuf' + + write (Just $! unsafeFreezeBuffer buf') os + cont + + InsertByteString op' bs bStep' -> do + let buf' = updateEndOfSlice buf op' + + case unsafeFreezeNonEmptyBuffer buf' of + Nothing -> return $! () + x -> write x os + + -- empty string here notifies downstream of flush + write (Just bs) os + + ioBuf' <- nextBuf 1 buf' + feed bStep' ioBuf' diff --git a/src/System/IO/Streams/ByteString.hs b/src/System/IO/Streams/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/ByteString.hs @@ -0,0 +1,747 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Stream operations on 'ByteString'. +module System.IO.Streams.ByteString + ( -- * Counting bytes + countInput + , countOutput + + -- * Treating strings as streams + , fromByteString + , fromLazyByteString + + -- * Input and output + , readExactly + , takeBytesWhile + , writeLazyByteString + + -- * Stream transformers + -- ** Splitting/Joining + , splitOn + , lines + , unlines + , words + , unwords + + -- ** Other + , giveBytes + , giveExactly + , takeBytes + , throwIfConsumesMoreThan + , throwIfProducesMoreThan + + -- ** Rate limiting + , throwIfTooSlow + + -- * String search + , MatchInfo(..) + , search + + -- * Exception types + , RateTooSlowException + , ReadTooShortException + , TooManyBytesReadException + , TooManyBytesWrittenException + , TooFewBytesWrittenException + + ) where + +------------------------------------------------------------------------------ +import Control.Exception (Exception, throwIO) +import Control.Monad (when, (>=>)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.ByteString.Unsafe as S +import Data.Char (isSpace) +import Data.Int (Int64) +import Data.IORef (IORef, newIORef, + readIORef, writeIORef) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Typeable (Typeable) + +import Prelude hiding (lines, read, + takeWhile, unlines, + unwords, words) +------------------------------------------------------------------------------ +import System.IO.Streams.Combinators (filterM, intersperse, + outputFoldM) +import System.IO.Streams.Internal (InputStream, OutputStream, + SP (..), Sink (..), + Source (..), + makeInputStream, + makeOutputStream, + nullSink, pushback, read, + sinkToStream, + sourceToStream, unRead, + write) +import System.IO.Streams.Internal.Search (MatchInfo (..), search) +import System.IO.Streams.List (fromList, writeList) +------------------------------------------------------------------------------ + +{-# INLINE modifyRef #-} +modifyRef :: IORef a -> (a -> a) -> IO () +modifyRef ref f = do + x <- readIORef ref + writeIORef ref $! f x + + +------------------------------------------------------------------------------ +-- | Writes a lazy 'ByteString' to an 'OutputStream'. +-- +-- Example: +-- +-- @ +-- ghci> Streams.'writeLazyByteString' \"Test\\n\" Streams.'System.IO.Streams.stdout' +-- Test +-- @ +writeLazyByteString :: L.ByteString -- ^ string to write to output + -> OutputStream ByteString -- ^ output stream + -> IO () +writeLazyByteString = writeList . L.toChunks +{-# INLINE writeLazyByteString #-} + + +------------------------------------------------------------------------------ +-- | Creates an 'InputStream' from a 'ByteString'. +fromByteString :: ByteString -> IO (InputStream ByteString) +fromByteString = fromList . (:[]) + + +------------------------------------------------------------------------------ +-- | Creates an 'InputStream' from a lazy 'ByteString'. +fromLazyByteString :: L.ByteString -> IO (InputStream ByteString) +fromLazyByteString = fromList . L.toChunks + + +------------------------------------------------------------------------------ +-- | Wraps an 'InputStream', counting the number of bytes produced by the +-- stream as a side effect. Produces a new 'InputStream' as well as an IO +-- action to retrieve the count of bytes produced. +-- +-- Strings pushed back to the returned 'InputStream' will be pushed back to the +-- original stream, and the count of produced bytes will be subtracted +-- accordingly. +-- +-- Example: +-- +-- @ +-- ghci> is <- Streams.'System.IO.Streams.fromList' [\"abc\", \"def\", \"ghi\"::ByteString] +-- ghci> (is', getCount) <- Streams.'countInput' is +-- ghci> Streams.'read' is' +-- Just \"abc\" +-- ghci> getCount +-- 3 +-- ghci> Streams.'unRead' \"bc\" is' +-- ghci> getCount +-- 1 +-- ghci> Streams.'System.IO.Streams.peek' is +-- Just \"bc\" +-- ghci> Streams.'System.IO.Streams.toList' is' +-- [\"bc\",\"def\",\"ghi\"] +-- ghci> getCount +-- 9 +-- @ +-- +countInput :: InputStream ByteString -> IO (InputStream ByteString, IO Int64) +countInput src = do + ref <- newIORef 0 + stream <- sourceToStream $ source ref + return $! (stream, readIORef ref) + + where + eof !ref = return $! SP (eofSrc ref) Nothing + + eofSrc !ref = Source { + produce = eof ref + , pushback = pb ref + } + + pb !ref !s = do + unRead s src + modifyRef ref $ \x -> x - (toEnum $ S.length s) + return $! source ref + + source ref = Source { + produce = read src >>= maybe (eof ref) chunk + , pushback = pb ref + } + where + chunk s = let !l = toEnum $ S.length s + in do + modifyRef ref (+ l) + return $! SP (source ref) (Just s) + + +------------------------------------------------------------------------------ +-- | Wraps an 'OutputStream', counting the number of bytes consumed by the +-- stream as a side effect. Produces a new 'OutputStream' as well as an IO +-- action to retrieve the count of bytes consumed. +-- +-- Example: +-- +-- @ +-- ghci> (os :: OutputStream ByteString, getList) <- Streams.'System.IO.Streams.listOutputStream' +-- ghci> (os', getCount) <- Streams.'countOutput' os +-- ghci> Streams.'System.IO.Streams.fromList' [\"abc\", \"def\", \"ghi\"] >>= Streams.'System.IO.Streams.connectTo' os' +-- ghci> getList +-- [\"abc\",\"def\",\"ghi\"] +-- ghci> getCount +-- 9 +-- @ +countOutput :: OutputStream ByteString + -> IO (OutputStream ByteString, IO Int64) +countOutput = outputFoldM f 0 + where + f !count s = return z + where + !c = S.length s + !z = toEnum c + count + + +------------------------------------------------------------------------------ +-- | Wraps an 'InputStream', producing a new 'InputStream' that will produce at +-- most @n@ bytes, subsequently yielding end-of-stream forever. +-- +-- Strings pushed back to the returned 'InputStream' will be propagated +-- upstream, modifying the count of taken bytes accordingly. +-- +-- Example: +-- +-- @ +-- ghci> is <- Streams.'System.IO.Streams.fromList' [\"truncated\", \" string\"::ByteString] +-- ghci> is' <- Streams.'takeBytes' 9 is +-- ghci> Streams.'read' is' +-- Just \"truncated\" +-- ghci> Streams.'read' is' +-- Nothing +-- ghci> Streams.'System.IO.Streams.peek' is +-- Just \" string\" +-- ghci> Streams.'unRead' \"cated\" is' +-- ghci> Streams.'System.IO.Streams.peek' is +-- Just \"cated\" +-- ghci> Streams.'System.IO.Streams.peek' is' +-- Just \"cated\" +-- ghci> Streams.'read' is' +-- Just \"cated\" +-- ghci> Streams.'read' is' +-- Nothing +-- ghci> Streams.'read' is +-- Just \" string\" +-- @ +takeBytes :: Int64 -- ^ maximum number of bytes to read + -> InputStream ByteString -- ^ input stream to wrap + -> IO (InputStream ByteString) +takeBytes k0 src = sourceToStream $ source k0 + where + fromBS s = if S.null s then Nothing else Just s + + eof !n = return $! SP (eofSrc n) Nothing + + eofSrc !n = Source (eof n) (pb n) + + pb !n s = do + unRead s src + return $! source $! n + toEnum (S.length s) + + source !k = Source (read src >>= maybe (eof k) chunk) (pb k) + where + chunk s = let l = toEnum $ S.length s + k' = k - l + in if k' <= 0 + then let (a,b) = S.splitAt (fromEnum k) s + in do + when (not $ S.null b) $ unRead b src + return $! SP (eofSrc 0) (fromBS a) + else return $! SP (source k') (Just s) + + +------------------------------------------------------------------------------ +-- | Splits an 'InputStream' over 'ByteString's using a delimiter predicate. +-- +-- Note that: +-- +-- * data pushed back with 'unRead' is *not* propagated upstream here. +-- +-- * the resulting 'InputStream' may hold an unbounded amount of the +-- bytestring in memory waiting for the function to return true, so this +-- function should not be used in unsafe contexts. +-- +-- * the delimiter is NOT included in the output. +-- +-- * consecutive delimiters are not merged. +-- +-- Example: +-- +-- @ +-- ghci> Streams.'System.IO.Streams.fromList' [\"the quick br\", \"own fox\"::'ByteString'] >>= +-- Streams.'splitOn' (== \' \') >>= Streams.'System.IO.Streams.toList' +-- [\"the\",\"quick\",\"brown\",\"\",\"fox\"] +-- @ +-- +splitOn :: (Char -> Bool) -- ^ predicate used to break the input + -- stream into chunks + -> InputStream ByteString -- ^ input stream + -> IO (InputStream ByteString) +splitOn p is = do + ref <- newIORef id + makeInputStream $ start ref + where + start ref = go + where + go = read is >>= maybe end chunk + + end = do + dl <- readIORef ref + case dl [] of + [] -> return Nothing + xs -> writeIORef ref id >> + (return $! Just $! S.concat xs) + + chunk s = let (a, b) = S.break p s + in if S.null b + then modifyRef ref (\f -> f . (a:)) >> go + else do + let !b' = S.unsafeDrop 1 b + dl <- readIORef ref + + if S.null b' + then do + writeIORef ref ("" :) + return $ Just $! S.concat $ dl [a] + else do + writeIORef ref id + unRead b' is + return $ Just $! S.concat $ dl [a] + + +------------------------------------------------------------------------------ +-- | Splits a bytestring 'InputStream' into lines. See 'splitOn' and +-- 'Prelude.lines'. +-- +-- Example: +-- +-- @ +-- ghci> is \<- Streams.'System.IO.Streams.fromList' [\"Hello,\\n world!\"] >>= Streams.'lines' +-- ghci> replicateM 3 (Streams.'read' is) +-- [Just \"Hello\", Just \", world!\", Nothing] +-- @ +-- +-- Note that this may increase the chunk size if the input contains extremely +-- long lines. +lines :: InputStream ByteString -> IO (InputStream ByteString) +lines = splitOn (== '\n') + + +------------------------------------------------------------------------------ +-- | Splits a bytestring 'InputStream' into words. See 'splitOn' and +-- 'Prelude.words'. +-- +-- Example: +-- +-- @ +-- ghci> is \<- Streams.'System.IO.Streams.fromList' [\"Hello, world!\"] >>= Streams.'words' +-- ghci> replicateM 3 (Streams.'read' is) +-- [Just \"Hello,\", Just \"world!\", Nothing] +-- @ +-- +-- Note that this may increase the chunk size if the input contains extremely +-- long words. +words :: InputStream ByteString -> IO (InputStream ByteString) +words = splitOn isSpace >=> filterM (return . not . S.all isSpace) + + +------------------------------------------------------------------------------ +-- | Intersperses string chunks sent to the given 'OutputStream' with newlines. +-- See 'intersperse' and 'Prelude.unlines'. +-- +-- @ +-- ghci> os <- Streams.'unlines' Streams.'System.IO.Streams.stdout' +-- ghci> Streams.'write' (Just \"Hello,\") os +-- Hello +-- ghci> Streams.'write' Nothing os +-- ghci> Streams.'write' (Just \"world!\") os +-- world! +-- @ +unlines :: OutputStream ByteString -> IO (OutputStream ByteString) +unlines os = makeOutputStream $ \m -> do + write m os + case m of + Nothing -> return $! () + Just _ -> write (Just "\n") os + + +------------------------------------------------------------------------------ +-- | Intersperses string chunks sent to the given 'OutputStream' with spaces. +-- See 'intersperse' and 'Prelude.unwords'. +-- +-- @ +-- ghci> os <- Streams.'unwords' Streams.'System.IO.Streams.stdout' +-- ghci> forM_ [Just \"Hello,\", Nothing, Just \"world!\\n\"] $ \w -> Streams.'write' w os +-- Hello, world! +-- @ +unwords :: OutputStream ByteString -> IO (OutputStream ByteString) +unwords = intersperse " " + + +------------------------------------------------------------------------------ +-- | Thrown by 'throwIfProducesMoreThan' when too many bytes were read from the +-- original 'InputStream'. +data TooManyBytesReadException = TooManyBytesReadException deriving (Typeable) + +instance Show TooManyBytesReadException where + show TooManyBytesReadException = "Too many bytes read" + +instance Exception TooManyBytesReadException + + +------------------------------------------------------------------------------ +-- | Thrown by 'giveExactly' when too few bytes were written to the produced +-- 'OutputStream'. +data TooFewBytesWrittenException = TooFewBytesWrittenException deriving (Typeable) + +instance Show TooFewBytesWrittenException where + show TooFewBytesWrittenException = "Too few bytes written" + +instance Exception TooFewBytesWrittenException + + +------------------------------------------------------------------------------ +-- | Thrown by 'throwIfConsumesMoreThan' when too many bytes were sent to the +-- produced 'OutputStream'. +data TooManyBytesWrittenException = + TooManyBytesWrittenException deriving (Typeable) + +instance Show TooManyBytesWrittenException where + show TooManyBytesWrittenException = "Too many bytes written" + +instance Exception TooManyBytesWrittenException + + +------------------------------------------------------------------------------ +-- | Thrown by 'readExactly' when not enough bytes were available on the input. +data ReadTooShortException = ReadTooShortException Int deriving (Typeable) + +instance Show ReadTooShortException where + show (ReadTooShortException x) = "Short read, expected " ++ show x + ++ " bytes" + +instance Exception ReadTooShortException + + +------------------------------------------------------------------------------ +-- | Wraps an 'InputStream'. If more than @n@ bytes are produced by this +-- stream, 'read' will throw a 'TooManyBytesReadException'. +-- +-- If a chunk yielded by the input stream would result in more than @n@ bytes +-- being produced, 'throwIfProducesMoreThan' will cut the generated string such +-- that exactly @n@ bytes are yielded by the returned stream, and the +-- /subsequent/ read will throw an exception. Example: +-- +-- @ +-- ghci> is \<- Streams.'System.IO.Streams.fromList' [\"abc\", \"def\", \"ghi\"] >>= +-- Streams.'throwIfProducesMoreThan' 5 +-- ghci> 'Control.Monad.replicateM' 2 ('read' is) +-- [Just \"abc\",Just \"de\"] +-- ghci> Streams.'read' is +-- *** Exception: Too many bytes read +-- @ +-- +-- Strings pushed back to the returned 'InputStream' will be propagated +-- upstream, modifying the count of taken bytes accordingly. Example: +-- +-- @ +-- ghci> is <- Streams.'System.IO.Streams.fromList' [\"abc\", \"def\", \"ghi\"] +-- ghci> is' <- Streams.'throwIfProducesMoreThan' 5 is +-- ghci> Streams.'read' is' +-- Just \"abc\" +-- ghci> Streams.'unRead' \"xyz\" is' +-- ghci> Streams.'System.IO.Streams.peek' is +-- Just \"xyz\" +-- ghci> Streams.'read' is +-- Just \"xyz\" +-- ghci> Streams.'read' is +-- Just \"de\" +-- ghci> Streams.'read' is +-- *** Exception: Too many bytes read +-- @ +-- +throwIfProducesMoreThan + :: Int64 -- ^ maximum number of bytes to read + -> InputStream ByteString -- ^ input stream + -> IO (InputStream ByteString) +throwIfProducesMoreThan k0 src = sourceToStream $ source k0 + where + eofSrc n = Source { + produce = eof n + , pushback = pb n + } + + eof n = return $! SP (eofSrc n) Nothing + + pb n s = do + unRead s src + return $! source $! n + toEnum (S.length s) + + source !k = Source prod (pb k) + where + prod = read src >>= maybe (eof k) chunk + + chunk s | l == 0 = return $! SP (source k) (Just s) + | k == 0 = throwIO TooManyBytesReadException + | k' >= 0 = return $! SP (source k') (Just s) + | otherwise = do + unRead b src + return $! SP (source 0) (Just a) + where + l = toEnum $ S.length s + k' = k - l + (a,b) = S.splitAt (fromEnum k) s + + +------------------------------------------------------------------------------ +-- | Reads an @n@-byte ByteString from an input stream. Throws a +-- 'ReadTooShortException' if fewer than @n@ bytes were available. +-- +-- Example: +-- +-- @ +-- ghci> Streams.'System.IO.Streams.fromList' [\"long string\"] >>= Streams.'readExactly' 6 +-- \"long s\" +-- ghci> Streams.'System.IO.Streams.fromList' [\"short\"] >>= Streams.'readExactly' 6 +-- *** Exception: Short read, expected 6 bytes +-- @ +-- +readExactly :: Int -- ^ number of bytes to read + -> InputStream ByteString -- ^ input stream + -> IO ByteString +readExactly n input = go id n + where + go !dl 0 = return $! S.concat $! dl [] + go !dl k = + read input >>= + maybe (throwIO $ ReadTooShortException n) + (\s -> do + let l = S.length s + if l >= k + then do + let (a,b) = S.splitAt k s + when (not $ S.null b) $ unRead b input + return $! S.concat $! dl [a] + else go (dl . (s:)) (k - l)) + + +------------------------------------------------------------------------------ +-- | Takes from a stream until the given predicate is no longer satisfied. +-- Returns Nothing on end-of-stream, or @Just \"\"@ if the predicate is never +-- satisfied. See 'Prelude.takeWhile' and 'Data.ByteString.Char8.takeWhile'. +-- +-- Example: +-- +-- @ +-- ghci> Streams.'System.IO.Streams.fromList' [\"Hello, world!\"] >>= Streams.'takeBytesWhile' (/= ',') +-- Just \"Hello\" +-- ghci> import Data.Char +-- ghci> Streams.'System.IO.Streams.fromList' [\"7 Samurai\"] >>= Streams.'takeBytesWhile' isAlpha +-- Just \"\" +-- ghci> Streams.'System.IO.Streams.fromList' [] >>= Streams.'takeBytesWhile' isAlpha +-- Nothing +-- @ +takeBytesWhile :: (Char -> Bool) -- ^ predicate + -> InputStream ByteString -- ^ input stream + -> IO (Maybe ByteString) +takeBytesWhile p input = read input >>= maybe (return Nothing) (go id) + where + go dl !s | S.null b = read input >>= maybe finish (go dl') + | otherwise = unRead b input >> finish + where + (a, b) = S.span p s + dl' = dl . (a:) + finish = return $! Just $! S.concat $! dl [a] + + +------------------------------------------------------------------------------ +-- | Wraps an 'OutputStream', producing a new stream that will pass along at +-- most @n@ bytes to the wrapped stream, throwing any subsequent input away. +-- +-- Example: +-- +-- @ +-- ghci> (os :: OutputStream ByteString, getList) <- Streams.'System.IO.Streams.listOutputStream' +-- ghci> os' <- Streams.'giveBytes' 6 os +-- ghci> Streams.'System.IO.Streams.fromList' [\"long \", \"string\"] >>= Streams.'System.IO.Streams.connectTo' os' +-- ghci> getList +-- [\"long \",\"s\"] +-- @ +giveBytes :: Int64 -- ^ maximum number of bytes to send + -- to the wrapped stream + -> OutputStream ByteString -- ^ output stream to wrap + -> IO (OutputStream ByteString) +giveBytes k0 str = sinkToStream $ sink k0 + where + sink !k = Sink g + where + g Nothing = write Nothing str >> return nullSink + + g mb@(Just x) = let l = toEnum $ S.length x + k' = k - l + in if k' < 0 + then do + let a = S.take (fromEnum k) x + when (not $ S.null a) $ write (Just a) str + return nullStr + else write mb str >> return (sink k') + + nullStr = Sink h + + h Nothing = write Nothing str >> return nullSink + h _ = return nullSink + + +------------------------------------------------------------------------------ +-- | Wraps an 'OutputStream', producing a new stream that will pass along +-- exactly @n@ bytes to the wrapped stream. If the stream is sent more or fewer +-- than the given number of bytes, the resulting stream will throw an exception +-- (either 'TooFewBytesWrittenException' or 'TooManyBytesWrittenException') +-- during a call to 'write'. +-- +-- Example: +-- +-- @ +-- ghci> is <- Streams.'System.IO.Streams.fromList' [\"ok\"] +-- ghci> Streams.'System.IO.Streams.outputToList' (Streams.'giveExactly' 2 >=> Streams.'System.IO.Streams.connect' is) +-- [\"ok\"] +-- ghci> is <- Streams.'System.IO.Streams.fromList' [\"ok\"] +-- ghci> Streams.'System.IO.Streams.outputToList' (Streams.'giveExactly' 1 >=> Streams.'System.IO.Streams.connect' is) +-- *** Exception: Too many bytes written +-- ghci> is <- Streams.'System.IO.Streams.fromList' [\"ok\"] +-- ghci> Streams.'System.IO.Streams.outputToList' (Streams.'giveExactly' 3 >=> Streams.'System.IO.Streams.connect' is) +-- *** Exception: Too few bytes written +-- @ +giveExactly :: Int64 + -> OutputStream ByteString + -> IO (OutputStream ByteString) +giveExactly k0 os = do + ref <- newIORef k0 + makeOutputStream $ go ref + where + go ref chunk = do + !n <- readIORef ref + case chunk of + Nothing -> if n /= 0 + then throwIO TooFewBytesWrittenException + else return $! () + Just s -> let n' = n - fromIntegral (S.length s) + in if n' < 0 + then throwIO TooManyBytesWrittenException + else do writeIORef ref n' + write chunk os + + +------------------------------------------------------------------------------ +-- | Wraps an 'OutputStream', producing a new stream that will pass along at +-- most @n@ bytes to the wrapped stream. If more than @n@ bytes are sent to the +-- outer stream, a 'TooManyBytesWrittenException' will be thrown. +-- +-- /Note/: if more than @n@ bytes are sent to the outer stream, +-- 'throwIfConsumesMoreThan' will not necessarily send the first @n@ bytes +-- through to the wrapped stream before throwing the exception. +-- +-- Example: +-- +-- @ +-- ghci> (os :: OutputStream ByteString, getList) <- Streams.'System.IO.Streams.listOutputStream' +-- ghci> os' <- Streams.'throwIfConsumesMoreThan' 5 os +-- ghci> Streams.'System.IO.Streams.fromList' [\"short\"] >>= Streams.'System.IO.Streams.connectTo' os' +-- ghci> getList +-- [\"short\"] +-- ghci> os'' <- Streams.'throwIfConsumesMoreThan' 5 os +-- ghci> Streams.'System.IO.Streams.fromList' [\"long\", \"string\"] >>= Streams.'System.IO.Streams.connectTo' os'' +-- *** Exception: Too many bytes written +-- @ +throwIfConsumesMoreThan + :: Int64 -- ^ maximum number of bytes to send to the + -- wrapped stream + -> OutputStream ByteString -- ^ output stream to wrap + -> IO (OutputStream ByteString) +throwIfConsumesMoreThan k0 str = sinkToStream $ sink k0 + where + sink !k = Sink g + where + g Nothing = write Nothing str >> return nullSink + + g mb@(Just x) = let l = toEnum $ S.length x + k' = k - l + in if k' < 0 + then throwIO TooManyBytesWrittenException + else write mb str >> return (sink k') + + +------------------------------------------------------------------------------ +-- | Gets the current posix time +getTime :: IO Double +getTime = realToFrac `fmap` getPOSIXTime + + +------------------------------------------------------------------------------ +-- | Thrown by 'throwIfTooSlow' if input is not being produced fast enough by +-- the given 'InputStream'. +-- +data RateTooSlowException = RateTooSlowException deriving (Typeable) +instance Show RateTooSlowException where + show RateTooSlowException = "Input rate too slow" +instance Exception RateTooSlowException + + +------------------------------------------------------------------------------ +-- | Rate-limits an input stream. If the input stream is not read from faster +-- than the given rate, reading from the wrapped stream will throw a +-- 'RateTooSlowException'. +-- +-- Strings pushed back to the returned 'InputStream' will be propagated up to +-- the original stream. +throwIfTooSlow + :: IO () -- ^ action to bump timeout + -> Double -- ^ minimum data rate, in bytes per second + -> Int -- ^ amount of time in seconds to wait before + -- data rate calculation takes effect + -> InputStream ByteString -- ^ input stream + -> IO (InputStream ByteString) +throwIfTooSlow !bump !minRate !minSeconds' !stream = do + !_ <- bump + startTime <- getTime + + sourceToStream $ source startTime 0 + + where + minSeconds = fromIntegral minSeconds' + + source !startTime = proc + where + eof !nb = return $! SP (eofSrc nb) Nothing + eofSrc !nb = Source { produce = eof nb + , pushback = pb nb } + + pb !nb s = do + unRead s stream + return $ proc $ nb - S.length s + + proc !nb = Source prod (pb nb) + where + prod = read stream >>= + maybe (eof nb) + (\s -> do + let slen = S.length s + now <- getTime + let !delta = now - startTime + let !newBytes = nb + slen + when (delta > minSeconds + 1 && + (fromIntegral newBytes / + (delta - minSeconds)) < minRate) $ + throwIO RateTooSlowException + + -- otherwise, bump the timeout and return the input + !_ <- bump + return $! SP (proc newBytes) (Just s)) diff --git a/src/System/IO/Streams/Combinators.hs b/src/System/IO/Streams/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Combinators.hs @@ -0,0 +1,763 @@ +-- | Generic stream manipulations + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module System.IO.Streams.Combinators + ( -- * Folds + inputFoldM + , outputFoldM + , fold + , foldM + , any + , all + , maximum + , minimum + + -- * Unfolds + , unfoldM + + -- * Maps + , map + , mapM + , mapM_ + , contramap + , contramapM + , contramapM_ + + -- * Filter + , filter + , filterM + , filterOutput + , filterOutputM + + -- * Takes and drops + , give + , take + , drop + , ignore + + -- * Zip and unzip + , zip + , zipWith + , zipWithM + , unzip + + -- * Utility + , intersperse + , skipToEof + ) where + +------------------------------------------------------------------------------ +import Control.Concurrent.MVar (newMVar, withMVar) +import Control.Monad (liftM, void, when) +import Control.Monad.IO.Class (liftIO) +import Data.Int (Int64) +import Data.IORef (atomicModifyIORef, modifyIORef, + newIORef, readIORef, writeIORef) +import Prelude hiding (all, any, drop, filter, map, + mapM, mapM_, maximum, minimum, + read, take, unzip, zip, zipWith) +------------------------------------------------------------------------------ +import System.IO.Streams.Internal (InputStream, OutputStream, SP (..), + Source (..), fromGenerator, + makeInputStream, makeOutputStream, + read, sourceToStream, unRead, + write, yield) + +------------------------------------------------------------------------------ +-- | A side-effecting fold over an 'OutputStream', as a stream transformer. +-- +-- The IO action returned by 'outputFoldM' can be used to fetch the updated +-- seed value. Example: +-- +-- @ +-- ghci> is <- Streams.'System.IO.Streams.List.fromList' [1, 2, 3::Int] +-- ghci> (os, getList) <- Streams.'System.IO.Streams.List.listOutputStream' +-- ghci> (os', getSeed) \<- Streams.'outputFoldM' (\\x y -> return (x+y)) 0 os +-- ghci> Streams.'System.IO.Streams.connect' is os' +-- ghci> getList +-- [1,2,3] +-- ghci> getSeed +-- 6 +-- @ +outputFoldM :: (a -> b -> IO a) -- ^ fold function + -> a -- ^ initial seed + -> OutputStream b -- ^ output stream + -> IO (OutputStream b, IO a) -- ^ returns a new stream as well as + -- an IO action to fetch the updated + -- seed value. +outputFoldM f initial stream = do + ref <- newIORef initial + os <- makeOutputStream (wr ref) + return (os, fetch ref) + + where + wr _ Nothing = write Nothing stream + wr ref mb@(Just x) = do + !z <- readIORef ref + !z' <- f z x + writeIORef ref z' + write mb stream + + fetch ref = atomicModifyIORef ref $ \x -> (initial, x) + + +------------------------------------------------------------------------------ +-- | A side-effecting fold over an 'InputStream', as a stream transformer. +-- +-- The IO action returned by 'inputFoldM' can be used to fetch the updated seed +-- value. Example: +-- +-- @ +-- ghci> is <- Streams.'System.IO.Streams.List.fromList' [1, 2, 3::Int] +-- ghci> (is', getSeed) \<- Streams.'inputFoldM' (\\x y -> return (x+y)) 0 is +-- ghci> Streams.'System.IO.Streams.List.toList' is' +-- [1,2,3] +-- ghci> getSeed +-- 6 +-- @ +inputFoldM :: (a -> b -> IO a) -- ^ fold function + -> a -- ^ initial seed + -> InputStream b -- ^ input stream + -> IO (InputStream b, IO a) -- ^ returns a new stream as well as an + -- IO action to fetch the updated seed + -- value. +inputFoldM f initial stream = do + ref <- newIORef initial + is <- makeInputStream (rd ref) + return (is, fetch ref) + + where + twiddle _ Nothing = return Nothing + + twiddle ref mb@(Just x) = do + !z <- readIORef ref + !z' <- f z x + writeIORef ref z' + return mb + + rd ref = read stream >>= twiddle ref + + fetch ref = atomicModifyIORef ref $ \x -> (initial, x) + + +------------------------------------------------------------------------------ +-- | A left fold over an input stream. The input stream is fully consumed. See +-- 'Prelude.foldl'. +-- +-- Example: +-- +-- @ +-- ghci> Streams.'System.IO.Streams.fromList' [1..10] >>= Streams.'fold' (+) 0 +-- 55 +-- @ +fold :: (s -> a -> s) -- ^ fold function + -> s -- ^ initial seed + -> InputStream a -- ^ input stream + -> IO s +fold f seed stream = go seed + where + go !s = read stream >>= maybe (return s) (go . f s) + + +------------------------------------------------------------------------------ +-- | A side-effecting left fold over an input stream. The input stream is fully +-- consumed. See 'Prelude.foldl'. +-- +-- Example: +-- +-- @ +-- ghci> Streams.'System.IO.Streams.fromList' [1..10] >>= Streams.'foldM' (\x y -> 'return' (x + y)) 0 +-- 55 +-- @ +foldM :: (s -> a -> IO s) -- ^ fold function + -> s -- ^ initial seed + -> InputStream a -- ^ input stream + -> IO s +foldM f seed stream = go seed + where + go !s = read stream >>= maybe (return s) ((go =<<) . f s) + + +------------------------------------------------------------------------------ +-- | @any predicate stream@ returns 'True' if any element in @stream@ matches +-- the predicate. +-- +-- 'any' consumes as few elements as possible, ending consumption if an element +-- satisfies the predicate. +-- +-- @ +-- ghci> is <- Streams.'System.IO.Streams.List.fromList' [1, 2, 3] +-- ghci> Streams.'System.IO.Streams.Combinators.any' (> 0) is -- Consumes one element +-- True +-- ghci> Streams.'System.IO.Streams.read' is +-- Just 2 +-- ghci> Streams.'System.IO.Streams.Combinators.any' even is -- Only 3 remains +-- False +-- @ +any :: (a -> Bool) -> InputStream a -> IO Bool +any predicate stream = go + where + go = do + mElem <- read stream + case mElem of + Nothing -> return False + Just e -> if predicate e then return True else go + + +------------------------------------------------------------------------------ +-- | @all predicate stream@ returns 'True' if every element in @stream@ matches +-- the predicate. +-- +-- 'all' consumes as few elements as possible, ending consumption if any element +-- fails the predicate. +-- +-- @ +-- ghci> is <- Streams.'System.IO.Streams.List.fromList' [1, 2, 3] +-- ghci> Streams.'System.IO.Streams.Combinators.all' (< 0) is -- Consumes one element +-- False +-- ghci> Streams.'System.IO.Streams.read' is +-- Just 2 +-- ghci> Streams.'System.IO.Streams.Combinators.all' odd is -- Only 3 remains +-- True +-- @ +all :: (a -> Bool) -> InputStream a -> IO Bool +all predicate stream = go + where + go = do + mElem <- read stream + case mElem of + Nothing -> return True + Just e -> if predicate e then go else return False + + +------------------------------------------------------------------------------ +-- | @maximum stream@ returns the greatest element in @stream@ or 'Nothing' if +-- the stream is empty. +-- +-- 'maximum' consumes the entire stream. +-- +-- @ +-- ghci> is <- Streams.'System.IO.Streams.List.fromList' [1, 2, 3] +-- ghci> Streams.'System.IO.Streams.Combinators.maximum' is +-- 3 +-- ghci> Streams.'System.IO.Streams.read' is -- The stream is now empty +-- Nothing +-- @ +maximum :: (Ord a) => InputStream a -> IO (Maybe a) +maximum stream = do + mElem0 <- read stream + case mElem0 of + Nothing -> return Nothing + Just e -> go e + where + go oldElem = do + mElem <- read stream + case mElem of + Nothing -> return (Just oldElem) + Just newElem -> go (max oldElem newElem) + + +------------------------------------------------------------------------------ +-- | @minimum stream@ returns the greatest element in @stream@ +-- +-- 'minimum' consumes the entire stream. +-- +-- @ +-- ghci> is <- Streams.'System.IO.Streams.List.fromList' [1, 2, 3] +-- ghci> Streams.'System.IO.Streams.Combinators.minimum' is +-- 1 +-- ghci> Streams.'System.IO.Streams.read' is -- The stream is now empty +-- Nothing +-- @ +minimum :: (Ord a) => InputStream a -> IO (Maybe a) +minimum stream = do + mElem0 <- read stream + case mElem0 of + Nothing -> return Nothing + Just e -> go e + where + go oldElem = do + mElem <- read stream + case mElem of + Nothing -> return (Just oldElem) + Just newElem -> go (min oldElem newElem) + + +------------------------------------------------------------------------------ +-- | @unfoldM f seed@ builds an 'InputStream' from successively applying @f@ to +-- the @seed@ value, continuing if @f@ produces 'Just' and halting on +-- 'Nothing'. +-- +-- @ +-- ghci> is \<- Streams.'System.IO.Streams.Combinators.unfoldM' (\n -> return $ if n < 3 then Just (n, n + 1) else Nothing) 0 +-- ghci> Streams.'System.IO.Streams.List.toList' is +-- [0,1,2] +-- @ +unfoldM :: (b -> IO (Maybe (a, b))) -> b -> IO (InputStream a) +unfoldM f seed = fromGenerator (go seed) + where + go oldSeed = do + m <- liftIO (f oldSeed) + case m of + Nothing -> return $! () + Just (a, newSeed) -> do + yield a + go newSeed + +------------------------------------------------------------------------------ +-- | Maps a pure function over an 'InputStream'. +-- +-- @map f s@ passes all output from @s@ through the function @f@. +-- +-- Satisfies the following laws: +-- +-- @ +-- Streams.'map' (g . f) === Streams.'map' f >=> Streams.'map' g +-- Streams.'map' 'id' === Streams.'makeInputStream' . Streams.'read' +-- @ +map :: (a -> b) -> InputStream a -> IO (InputStream b) +map f s = makeInputStream g + where + g = read s >>= return . fmap f + + +------------------------------------------------------------------------------ +-- | Maps an impure function over an 'InputStream'. +-- +-- @mapM f s@ passes all output from @s@ through the IO action @f@. +-- +-- Satisfies the following laws: +-- +-- @ +-- Streams.'mapM' (f >=> g) === Streams.'mapM' f >=> Streams.'mapM' g +-- Streams.'mapM' 'return' === Streams.'makeInputStream' . Streams.'read' +-- @ +-- +mapM :: (a -> IO b) -> InputStream a -> IO (InputStream b) +mapM f s = makeInputStream g + where + g = do + mb <- read s >>= maybe (return Nothing) + (\x -> liftM Just $ f x) + + return mb + + +------------------------------------------------------------------------------ +-- | Maps a side effect over an 'InputStream'. +-- +-- @mapM_ f s@ produces a new input stream that passes all output from @s@ +-- through the side-effecting IO action @f@. +-- +-- Example: +-- +-- @ +-- ghci> Streams.'System.IO.Streams.fromList' [1,2,3] >>= +-- Streams.'mapM_' ('putStrLn' . 'show' . (*2)) >>= +-- Streams.'System.IO.Streams.toList' +-- 2 +-- 4 +-- 6 +-- [1,2,3] +-- @ +-- +mapM_ :: (a -> IO b) -> InputStream a -> IO (InputStream a) +mapM_ f s = makeInputStream $ do + mb <- read s + _ <- maybe (return $! ()) (void . f) mb + return mb + + +------------------------------------------------------------------------------ +-- | Contravariant counterpart to 'map'. +-- +-- @contramap f s@ passes all input to @s@ through the function @f@. +-- +-- Satisfies the following laws: +-- +-- @ +-- Streams.'contramap' (g . f) === Streams.'contramap' g >=> Streams.'contramap' f +-- Streams.'contramap' 'id' === 'return' +-- @ +contramap :: (a -> b) -> OutputStream b -> IO (OutputStream a) +contramap f s = makeOutputStream $ flip write s . fmap f + + +------------------------------------------------------------------------------ +-- | Contravariant counterpart to 'mapM'. +-- +-- @contramapM f s@ passes all input to @s@ through the IO action @f@ +-- +-- Satisfies the following laws: +-- +-- @ +-- Streams.'contramapM' (f >=> g) = Streams.'contramapM' g >=> Streams.'contramapM' f +-- Streams.'contramapM' 'return' = 'return' +-- @ +contramapM :: (a -> IO b) -> OutputStream b -> IO (OutputStream a) +contramapM f s = makeOutputStream g + where + g Nothing = write Nothing s + + g (Just x) = do + !y <- f x + write (Just y) s + + +------------------------------------------------------------------------------ +-- | Equivalent to 'mapM_' for output. +-- +-- @contramapM f s@ passes all input to @s@ through the side-effecting IO +-- action @f@. +-- +contramapM_ :: (a -> IO b) -> OutputStream a -> IO (OutputStream a) +contramapM_ f s = makeOutputStream $ \mb -> do + _ <- maybe (return $! ()) (void . f) mb + write mb s + + +------------------------------------------------------------------------------ +-- | Drives an 'InputStream' to end-of-stream, discarding all of the yielded +-- values. +skipToEof :: InputStream a -> IO () +skipToEof str = go + where + go = read str >>= maybe (return $! ()) (const go) +{-# INLINE skipToEof #-} + + +------------------------------------------------------------------------------ +-- | Drops chunks from an input stream if they fail to match a given filter +-- predicate. See 'Prelude.filter'. +-- +-- Items pushed back to the returned stream are propagated back upstream. +-- +-- Example: +-- +-- @ +-- ghci> Streams.'System.IO.Streams.fromList' [\"the\", \"quick\", \"brown\", \"fox\"] >>= +-- Streams.'filterM' ('return' . (/= \"brown\")) >>= Streams.'System.IO.Streams.toList' +-- [\"the\",\"quick\",\"fox\"] +-- @ +filterM :: (a -> IO Bool) + -> InputStream a + -> IO (InputStream a) +filterM p src = sourceToStream source + where + source = Source { + produce = prod + , pushback = pb + } + + prod = read src >>= maybe eof chunk + + chunk s = do + b <- p s + if b then return $! SP source (Just s) + else prod + + eof = return $! flip SP Nothing Source { + produce = eof + , pushback = pb + } + + pb s = unRead s src >> return source + + +------------------------------------------------------------------------------ +-- | Drops chunks from an input stream if they fail to match a given filter +-- predicate. See 'Prelude.filter'. +-- +-- Items pushed back to the returned stream are propagated back upstream. +-- +-- Example: +-- +-- @ +-- ghci> Streams.'System.IO.Streams.fromList' [\"the\", \"quick\", \"brown\", \"fox\"] >>= +-- Streams.'filter' (/= \"brown\") >>= Streams.'System.IO.Streams.toList' +-- [\"the\",\"quick\",\"fox\"] +-- @ +filter :: (a -> Bool) + -> InputStream a + -> IO (InputStream a) +filter p src = sourceToStream source + where + source = Source { + produce = prod + , pushback = pb + } + + prod = read src >>= maybe eof chunk + + chunk s = do + let b = p s + if b then return $! SP source (Just s) + else prod + + eof = return $! flip SP Nothing Source { + produce = eof + , pushback = pb + } + + pb s = unRead s src >> return source + + +------------------------------------------------------------------------------ +-- | The function @intersperse v s@ wraps the 'OutputStream' @s@, creating a +-- new output stream that writes its input to @s@ interspersed with the +-- provided value @v@. See 'Data.List.intersperse'. +-- +-- Example: +-- +-- @ +-- ghci> import Control.Monad ((>=>)) +-- ghci> is <- Streams.'System.IO.Streams.List.fromList' [\"nom\", \"nom\", \"nom\"::'ByteString'] +-- ghci> Streams.'System.IO.Streams.List.outputToList' (Streams.'intersperse' \"burp!\" >=> Streams.'System.IO.Streams.connect' is) +-- [\"nom\",\"burp!\",\"nom\",\"burp!\",\"nom\"] +-- @ +intersperse :: a -> OutputStream a -> IO (OutputStream a) +intersperse sep os = newIORef False >>= makeOutputStream . f + where + f _ Nothing = write Nothing os + f sendRef s = do + b <- readIORef sendRef + writeIORef sendRef True + when b $ write (Just sep) os + write s os + + +------------------------------------------------------------------------------ +-- | Combines two input streams. Continues yielding elements from both input +-- streams until one of them finishes. +zip :: InputStream a -> InputStream b -> IO (InputStream (a, b)) +zip src1 src2 = makeInputStream src + where + src = read src1 >>= (maybe (return Nothing) $ \a -> + read src2 >>= (maybe (unRead a src1 >> return Nothing) $ \b -> + return $! Just $! (a, b))) + + +------------------------------------------------------------------------------ +-- | Combines two input streams using the supplied function. Continues yielding +-- elements from both input streams until one of them finishes. +zipWith :: (a -> b -> c) + -> InputStream a + -> InputStream b + -> IO (InputStream c) +zipWith f src1 src2 = makeInputStream src + where + src = read src1 >>= (maybe (return Nothing) $ \a -> + read src2 >>= (maybe (unRead a src1 >> return Nothing) $ \b -> + return $! Just $! f a b ) ) + + +------------------------------------------------------------------------------ +-- | Combines two input streams using the supplied monadic function. Continues +-- yielding elements from both input streams until one of them finishes. +zipWithM :: (a -> b -> IO c) + -> InputStream a + -> InputStream b + -> IO (InputStream c) +zipWithM f src1 src2 = makeInputStream src + where + src = read src1 >>= (maybe (return Nothing) $ \a -> + read src2 >>= (maybe (unRead a src1 >> return Nothing) $ \b -> + f a b >>= \c -> return $! Just $! c ) ) + + +------------------------------------------------------------------------------ +-- | Filters output to be sent to the given 'OutputStream' using a pure +-- function. See 'filter'. +-- +-- Example: +-- +-- @ +-- ghci> import qualified "Data.ByteString.Char8" as S +-- ghci> os1 \<- Streams.'System.IO.Streams.stdout' >>= Streams.'System.IO.Streams.unlines +-- ghci> os2 \<- os1 >>= Streams.'contramap' (S.pack . show) >>= Streams.'filterOutput' even +-- ghci> Streams.'write' (Just 3) os2 +-- ghci> Streams.'write' (Just 4) os2 +-- 4 +-- @ +{- Note: The example is a lie, because unlines has weird behavior -} +filterOutput :: (a -> Bool) -> OutputStream a -> IO (OutputStream a) +filterOutput p output = makeOutputStream chunk + where + chunk Nothing = write Nothing output + chunk ch@(Just x) = when (p x) $ write ch output + + +------------------------------------------------------------------------------ +-- | Filters output to be sent to the given 'OutputStream' using a predicate +-- function in IO. See 'filterM'. +-- +-- Example: +-- +-- @ +-- ghci> let check a = putStrLn a ("Allow " ++ show a ++ "?") >> readLn :: IO Bool +-- ghci> import qualified Data.ByteString.Char8 as S +-- ghci> os1 <- Streams.'System.IO.Streams.unlines' Streams.'System.IO.Streams.stdout' +-- ghci> os2 \<- os1 >>= Streams.'contramap' (S.pack . show) >>= Streams.'filterOutputM' check +-- ghci> Streams.'System.IO.Streams.write' (Just 3) os2 +-- Allow 3? +-- False\ +-- ghci> Streams.'System.IO.Streams.write' (Just 4) os2 +-- Allow 4? +-- True\ +-- 4 +-- @ +filterOutputM :: (a -> IO Bool) -> OutputStream a -> IO (OutputStream a) +filterOutputM p output = makeOutputStream chunk + where + chunk Nothing = write Nothing output + chunk ch@(Just x) = do + b <- p x + if b then write ch output else return $! () + + +------------------------------------------------------------------------------ +-- | Takes apart a stream of pairs, producing a pair of input streams. Reading +-- from either of the produced streams will cause a pair of values to be pulled +-- from the original stream if necessary. Note that reading @n@ values from one +-- of the returned streams will cause @n@ values to be buffered at the other +-- stream. +-- +-- Access to the original stream is thread safe, i.e. guarded by a lock. +unzip :: InputStream (a, b) -> IO (InputStream a, InputStream b) +unzip os = do + lock <- newMVar $! () + buf1 <- newIORef id + buf2 <- newIORef id + + is1 <- makeInputStream $ src lock id buf1 buf2 + is2 <- makeInputStream $ src lock twist buf2 buf1 + + return (is1, is2) + + where + twist (a, b) = (b, a) + + src lock proj myBuf theirBuf = withMVar lock $ const $ do + dl <- readIORef myBuf + + case dl [] of + [] -> more + (x:xs) -> writeIORef myBuf (xs++) >> (return $! Just x) + where + more = read os >>= + maybe (return Nothing) + (\x -> do + let (a, b) = proj x + modifyIORef theirBuf (. (b:)) + return $! Just a) + + +------------------------------------------------------------------------------ +-- | Wraps an 'InputStream', producing a new 'InputStream' that will produce at +-- most @n@ items, subsequently yielding end-of-stream forever. +-- +-- Items pushed back to the returned 'InputStream' will be propagated upstream, +-- modifying the count of taken items accordingly. +-- +-- Example: +-- +-- @ +-- ghci> is <- Streams.'fromList' [1..9::Int] +-- ghci> is' <- Streams.'take' 1 is +-- ghci> Streams.'read' is' +-- Just 1 +-- ghci> Streams.'read' is' +-- Nothing +-- ghci> Streams.'System.IO.Streams.peek' is +-- Just 2 +-- ghci> Streams.'unRead' 11 is' +-- ghci> Streams.'System.IO.Streams.peek' is +-- Just 11 +-- ghci> Streams.'System.IO.Streams.peek' is' +-- Just 11 +-- ghci> Streams.'read' is' +-- Just 11 +-- ghci> Streams.'read' is' +-- Nothing +-- ghci> Streams.'read' is +-- Just 2 +-- ghci> Streams.'toList' is +-- [3,4,5,6,7,8,9] +-- @ +-- +take :: Int64 -> InputStream a -> IO (InputStream a) +take k0 input = sourceToStream $ source k0 + where + eof !n = return $! SP (eofSrc n) Nothing + eofSrc !n = Source (eof n) (pb n) + pb !n s = do + unRead s input + return $! source $! n + 1 + + source !k | k <= 0 = eofSrc k + | otherwise = Source (read input >>= maybe (eof k) chunk) (pb k) + where + chunk x = return $! SP (source (k - 1)) (Just x) + + +------------------------------------------------------------------------------ +-- | Wraps an 'InputStream', producing a new 'InputStream' that will drop the +-- first @n@ items produced by the wrapped stream. See 'Prelude.drop'. +-- +-- Items pushed back to the returned 'InputStream' will be propagated upstream, +-- modifying the count of dropped items accordingly. +drop :: Int64 -> InputStream a -> IO (InputStream a) +drop k0 input = sourceToStream $ source k0 + where + source !k | k <= 0 = normalSrc k + | otherwise = Source (discard k) (pb k) + + + getInput k = read input >>= maybe (eof k) + (return . SP (source (k - 1)) . Just) + normalSrc k = Source (getInput k) (pb k) + + eof !n = return $! SP (eofSrc n) Nothing + eofSrc !n = Source (eof n) (pb n) + + pb !n s = do + unRead s input + return $! source $! n + 1 + + discard k | k <= 0 = getInput k + | otherwise = read input >>= maybe (eof k) + (const $ discard $! k - 1) + + +------------------------------------------------------------------------------ +-- | Wraps an 'OutputStream', producing a new 'OutputStream' that will pass at +-- most @n@ items on to the wrapped stream, subsequently ignoring the rest of +-- the input. +-- +give :: Int64 -> OutputStream a -> IO (OutputStream a) +give k output = newIORef k >>= makeOutputStream . chunk + where + chunk ref = maybe (return $! ()) $ \x -> do + !n <- readIORef ref + if n <= 0 + then return $! () + else do + writeIORef ref $! n - 1 + write (Just x) output + + +------------------------------------------------------------------------------ +-- | Wraps an 'OutputStream', producing a new 'OutputStream' that will ignore +-- the first @n@ items received, subsequently passing the rest of the input on +-- to the wrapped stream. +-- +ignore :: Int64 -> OutputStream a -> IO (OutputStream a) +ignore k output = newIORef k >>= makeOutputStream . chunk + where + chunk ref = maybe (return $! ()) $ \x -> do + !n <- readIORef ref + if n > 0 + then writeIORef ref $! n - 1 + else write (Just x) output diff --git a/src/System/IO/Streams/Concurrent.hs b/src/System/IO/Streams/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Concurrent.hs @@ -0,0 +1,99 @@ +-- | Stream utilities for working with concurrent channels. + +{-# LANGUAGE BangPatterns #-} + +module System.IO.Streams.Concurrent + ( -- * Channel conversions + inputToChan + , chanToInput + , chanToOutput + , concurrentMerge + ) where + +------------------------------------------------------------------------------ +import Control.Concurrent (forkIO) +import Control.Concurrent.Chan (Chan, readChan, writeChan) +import Control.Concurrent.MVar (modifyMVar, newEmptyMVar, + newMVar, putMVar, takeMVar) +import Control.Exception (SomeException, mask, throwIO, + try) +import Control.Monad (forM_) +import Data.Maybe (isNothing) +import Prelude hiding (read) +------------------------------------------------------------------------------ +import System.IO.Streams.Internal (InputStream, OutputStream, + SP (..), makeInputStream, + makeOutputStream, nullSource, + read, sourceToStream, + withDefaultPushback) + +------------------------------------------------------------------------------ +-- | Writes the contents of an input stream to a channel until the input stream +-- yields end-of-stream. +inputToChan :: InputStream a -> Chan (Maybe a) -> IO () +inputToChan is ch = go + where + go = do + mb <- read is + writeChan ch mb + maybe (return ()) (const go) mb + + +------------------------------------------------------------------------------ +-- | Turns a 'Chan' into an input stream. +-- +chanToInput :: Chan (Maybe a) -> IO (InputStream a) +chanToInput ch = sourceToStream src + where + src = withDefaultPushback $ do + mb <- readChan ch + let src' = if isNothing mb then nullSource else src + return $! SP src' mb + + +------------------------------------------------------------------------------ +-- | Turns a 'Chan' into an output stream. +-- +chanToOutput :: Chan (Maybe a) -> IO (OutputStream a) +chanToOutput = makeOutputStream . writeChan + + +------------------------------------------------------------------------------ +-- | Concurrently merges a list of 'InputStream's, combining values in the +-- order they become available. +-- +-- Note: does /not/ forward individual end-of-stream notifications, the +-- produced stream does not yield end-of-stream until all of the input streams +-- have finished. +-- +-- This traps exceptions in each concurrent thread and re-raises them in the +-- current thread. +concurrentMerge :: [InputStream a] -> IO (InputStream a) +concurrentMerge iss = do + mv <- newEmptyMVar + nleft <- newMVar $! length iss + mask $ \restore -> forM_ iss $ \is -> forkIO $ do + let producer = do + emb <- try $ restore $ read is + case emb of + Left exc -> do putMVar mv (Left (exc :: SomeException)) + producer + Right Nothing -> putMVar mv $! Right Nothing + Right x -> putMVar mv (Right x) >> producer + producer + makeInputStream $ chunk mv nleft + + where + chunk mv nleft = do + emb <- takeMVar mv + case emb of + Left exc -> throwIO exc + Right Nothing -> do b <- modifyMVar nleft $ \n -> + let !n' = n - 1 + in return $! if n' == 0 + then (n', False) + else (n', True) + if b + then chunk mv nleft + else return Nothing + Right x -> return x diff --git a/src/System/IO/Streams/Core.hs b/src/System/IO/Streams/Core.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Core.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Core types and functions for the @io-streams@ library. +-- +module System.IO.Streams.Core + ( -- * Stream types + InputStream + , OutputStream + + -- * Creating streams + , makeInputStream + , makeOutputStream + + -- * Primitive stream operations + , read + , unRead + , peek + , write + , atEOF + + -- * Connecting streams together + , connect + , connectTo + , supply + , supplyTo + + -- * Thread safety \/ concurrency + , lockingInputStream + , lockingOutputStream + + -- * Utility streams + , nullInput + , nullOutput + + -- * Generator monad + , Generator + , fromGenerator + , yield + ) where + +import Prelude () +import System.IO.Streams.Internal diff --git a/src/System/IO/Streams/Debug.hs b/src/System/IO/Streams/Debug.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Debug.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Convenience module for debugging streams. Provides stream transformers +-- that wrap 'InputStream's and 'OutputStream's, sending a description of all +-- data to an 'OutputStream' for debugging. + +module System.IO.Streams.Debug + ( -- * Debuggers + debugInput + , debugOutput + , debugInputBS + , debugOutputBS + ) where + +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import System.IO.Streams.Internal (InputStream, OutputStream) +import qualified System.IO.Streams.Internal as Streams + +------------------------------------------------------------------------------ +debugInput :: + (a -> ByteString) -- ^ function to convert stream elements to + -- 'ByteString' + -> ByteString -- ^ name of this debug stream, will be + -- prepended to debug output + -> OutputStream ByteString -- ^ stream the debug info will be sent to + -> InputStream a -- ^ input stream + -> IO (InputStream a) +debugInput toBS name debugStream inputStream = + Streams.sourceToStream source + where + source = Streams.Source produce pb + + produce = do + m <- Streams.read inputStream + Streams.write (Just $ describe m) debugStream + return $! Streams.SP source m + + pb c = do + let s = S.concat [name, ": pushback: ", toBS c, "\n"] + Streams.write (Just s) debugStream + Streams.unRead c inputStream >> return source + + describe m = S.concat [name, ": got ", describeChunk m, "\n"] + + describeChunk Nothing = "EOF" + describeChunk (Just s) = S.concat [ "chunk: ", toBS s ] + + +------------------------------------------------------------------------------ +debugInputBS :: + ByteString -- ^ name of this debug stream, will be + -- prepended to debug output + -> OutputStream ByteString -- ^ stream the debug info will be sent to + -> InputStream ByteString -- ^ input stream + -> IO (InputStream ByteString) +debugInputBS = debugInput condense + + +------------------------------------------------------------------------------ +debugOutput :: (a -> ByteString) -- ^ function to convert stream + -- elements to 'ByteString' + -> ByteString -- ^ name of this debug stream, will be + -- prepended to debug output + -> OutputStream ByteString -- ^ debug stream + -> OutputStream a -- ^ output stream + -> IO (OutputStream a) +debugOutput toBS name debugStream outputStream = + Streams.makeOutputStream f + where + f m = do + Streams.write (Just $ describe m) debugStream + Streams.write m outputStream + + describe m = S.concat [name, ": got ", describeChunk m, "\n"] + + describeChunk Nothing = "EOF" + describeChunk (Just s) = S.concat [ "chunk: ", toBS s] + + +------------------------------------------------------------------------------ +debugOutputBS :: + ByteString -- ^ name of this debug stream, will be + -- prepended to debug output + -> OutputStream ByteString -- ^ stream the debug info will be sent to + -> OutputStream ByteString -- ^ output stream + -> IO (OutputStream ByteString) +debugOutputBS = debugOutput condense + + +------------------------------------------------------------------------------ +condense :: ByteString -> ByteString +condense s | l < 32 = S.concat [ "\"", s, "\"" ] + | otherwise = S.concat [ + "\"" + , S.take k s + , " ... " + , S.drop (l - k) s + , "\" (" + , S.pack (show l) + , " bytes)" + ] + where + k = 14 + l = S.length s diff --git a/src/System/IO/Streams/File.hs b/src/System/IO/Streams/File.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/File.hs @@ -0,0 +1,93 @@ +-- | Input and output streams for files. +-- +-- The functions in this file use \"with*\" or \"bracket\" semantics, i.e. they +-- open the supplied 'FilePath', run a user computation, and then close the +-- file handle. If you need more control over the lifecycle of the underlying +-- file descriptor resources, you are encouraged to use the functions from +-- "System.IO.Streams.Handle" instead. +module System.IO.Streams.File + ( -- * File conversions + withFileAsInput + , withFileAsInputStartingAt + , unsafeWithFileAsInputStartingAt + , withFileAsOutput + , withFileAsOutputExt + ) where + +------------------------------------------------------------------------------ +import Control.Monad (unless) +import Data.ByteString (ByteString) +import Data.Int (Int64) +import System.IO (BufferMode (NoBuffering), + IOMode (ReadMode, WriteMode), + SeekMode (AbsoluteSeek), hSeek, + hSetBuffering, withBinaryFile) +------------------------------------------------------------------------------ +import System.IO.Streams.Handle +import System.IO.Streams.Internal (InputStream, OutputStream) + + +------------------------------------------------------------------------------ +-- | @'withFileAsInput' name act@ opens the specified file in \"read mode\" and +-- passes the resulting 'InputStream' to the computation @act@. The file will +-- be closed on exit from @withFileAsInput@, whether by normal termination or +-- by raising an exception. +-- +-- If closing the file raises an exception, then /that/ exception will be +-- raised by 'withFileAsInput' rather than any exception raised by @act@. +withFileAsInput :: FilePath -- ^ file to open + -> (InputStream ByteString -> IO a) -- ^ function to run + -> IO a +withFileAsInput = withFileAsInputStartingAt 0 + + +------------------------------------------------------------------------------ +-- | Like 'withFileAsInput', but seeks to the specified byte offset before +-- attaching the given file descriptor to the 'InputStream'. +withFileAsInputStartingAt + :: Int64 -- ^ starting index to seek to + -> FilePath -- ^ file to open + -> (InputStream ByteString -> IO a) -- ^ function to run + -> IO a +withFileAsInputStartingAt idx fp m = withBinaryFile fp ReadMode go + where + go h = do + unless (idx == 0) $ hSeek h AbsoluteSeek $ toInteger idx + handleToInputStream h >>= m + + +------------------------------------------------------------------------------ +-- | Like 'withFileAsInputStartingAt', except that the 'ByteString' emitted by +-- the created 'InputStream' may reuse its buffer. You may only use this +-- function if you do not retain references to the generated bytestrings +-- emitted. +unsafeWithFileAsInputStartingAt + :: Int64 -- ^ starting index to seek to + -> FilePath -- ^ file to open + -> (InputStream ByteString -> IO a) -- ^ function to run + -> IO a +unsafeWithFileAsInputStartingAt = withFileAsInputStartingAt + + +------------------------------------------------------------------------------ +-- | Open a file for writing and attaches an 'OutputStream' for you to write +-- to. The file will be closed on error or completion of your action. +withFileAsOutput + :: FilePath -- ^ file to open + -> (OutputStream ByteString -> IO a) -- ^ function to run + -> IO a +withFileAsOutput f = withFileAsOutputExt f WriteMode NoBuffering + + +------------------------------------------------------------------------------ +-- | Like 'withFileAsOutput', but allowing you control over the output file +-- mode and buffering behaviour. +withFileAsOutputExt + :: FilePath -- ^ file to open + -> IOMode -- ^ mode to write in + -> BufferMode -- ^ should we buffer the output? + -> (OutputStream ByteString -> IO a) -- ^ function to run + -> IO a +withFileAsOutputExt fp iomode buffermode m = withBinaryFile fp iomode $ \h -> do + hSetBuffering h buffermode + handleToOutputStream h >>= m diff --git a/src/System/IO/Streams/Handle.hs b/src/System/IO/Streams/Handle.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Handle.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif + +-- | Input and output streams for file 'Handle's. +module System.IO.Streams.Handle + ( -- * Handle conversions + handleToInputStream + , handleToOutputStream + , stdin + , stdout + , stderr + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import System.IO (Handle, hFlush) +import qualified System.IO as IO +import System.IO.Unsafe (unsafePerformIO) +------------------------------------------------------------------------------ +import System.IO.Streams.Internal (InputStream, OutputStream, + lockingInputStream, + lockingOutputStream, + makeInputStream, + makeOutputStream) + + +------------------------------------------------------------------------------ +bUFSIZ :: Int +bUFSIZ = 32752 + + +------------------------------------------------------------------------------ +-- | Converts a read-only handle into an 'InputStream' of strict 'ByteString's. +handleToInputStream :: Handle -> IO (InputStream ByteString) +handleToInputStream h = makeInputStream f + where + f = do + x <- S.hGetSome h bUFSIZ + return $! if S.null x then Nothing else Just x + + +------------------------------------------------------------------------------ +-- | Converts a writable handle into an 'OutputStream' of strict 'ByteString's. +handleToOutputStream :: Handle -> IO (OutputStream ByteString) +handleToOutputStream h = makeOutputStream f + where + f Nothing = return $! () + f (Just x) = if S.null x + then hFlush h + else S.hPut h x + + +------------------------------------------------------------------------------ +-- | An 'InputStream' for 'IO.stdin'. +stdin :: InputStream ByteString +stdin = unsafePerformIO (handleToInputStream IO.stdin >>= lockingInputStream) +{-# NOINLINE stdin #-} + + +------------------------------------------------------------------------------ +-- | An 'OutputStream' for 'IO.stdout'. +stdout :: OutputStream ByteString +stdout = unsafePerformIO (handleToOutputStream IO.stdout >>= + lockingOutputStream) +{-# NOINLINE stdout #-} + + +------------------------------------------------------------------------------ +-- | An 'OutputStream' for 'IO.stderr'. +stderr :: OutputStream ByteString +stderr = unsafePerformIO (handleToOutputStream IO.stderr >>= + lockingOutputStream) +{-# NOINLINE stderr #-} diff --git a/src/System/IO/Streams/Internal.hs b/src/System/IO/Streams/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Internal.hs @@ -0,0 +1,724 @@ +-- | Internal implementation of the @io-streams@ library, intended for library +-- writers +-- +-- Library users should use the interface provided by "System.IO.Streams" + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module System.IO.Streams.Internal + ( -- * Types + SP(..) + , Source(..) + , Sink(..) + + -- * About pushback + -- $pushback + + -- * Pushback functions + , defaultPushback + , withDefaultPushback + + -- * Basic sources and sinks + , nullSource + , nullSink + , singletonSource + , simpleSource + + -- * Input and output streams + , InputStream(..) + , OutputStream(..) + + -- * Primitive stream operations + , read + , unRead + , peek + , write + , atEOF + + -- * Building streams + , sourceToStream + , sinkToStream + , makeInputStream + , makeOutputStream + , appendInputStream + , concatInputStreams + + -- * Connecting streams + , connect + , connectTo + , supply + , supplyTo + + -- * Thread safety + , lockingInputStream + , lockingOutputStream + + -- * Utility streams + , nullInput + , nullOutput + + -- * Generator monad + , Generator + , generatorToSource + , fromGenerator + , yield + + -- * Consumer monad + , Consumer + , consumerToSink + , fromConsumer + , await + ) where + +------------------------------------------------------------------------------ +import Control.Applicative (Applicative (..)) +import Control.Concurrent (newMVar, withMVar) +import Control.Monad (liftM, (>=>)) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.IORef (IORef, newIORef, readIORef, + writeIORef) +import Data.Monoid (Monoid (..)) +import Prelude hiding (read) + + +------------------------------------------------------------------------------ +-- | A strict pair type. +data SP a b = SP !a !b + +------------------------------------------------------------------------------ +-- | A 'Source' generates values of type @c@ in the 'IO' monad. +-- +-- 'Source's wrap ordinary values in a 'Just' and signal end-of-stream by +-- yielding 'Nothing'. +-- +-- All 'Source's define an optional push-back mechanism. You can assume that: +-- +-- @ +-- Streams.'pushback' source c >>= Streams.'produce' = 'return' (source, 'Just' c) +-- @ +-- +-- ... unless a 'Source' documents otherwise. +-- +-- 'Source' is to be considered an implementation detail of the library, and +-- should only be used in code that needs explicit control over the 'pushback' +-- semantics. +-- +-- Most library users should instead directly use 'InputStream's, which prevent +-- reuse of previous 'Source's. +data Source c = Source { + produce :: IO (SP (Source c) (Maybe c)) + , pushback :: c -> IO (Source c) + } + + +------------------------------------------------------------------------------ +-- | A 'Generator' is a coroutine monad that can be used to define complex +-- 'InputStream's. You can cause a value of type @Just r@ to appear when the +-- 'InputStream' is read by calling 'yield': +-- +-- @ +-- g :: 'Generator' Int () +-- g = do +-- Streams.'yield' 1 +-- Streams.'yield' 2 +-- Streams.'yield' 3 +-- @ +-- +-- A 'Generator' can be turned into an 'InputStream' by calling +-- 'fromGenerator': +-- +-- @ +-- m :: 'IO' ['Int'] +-- m = Streams.'fromGenerator' g >>= Streams.'System.IO.Streams.toList' \-\- value returned is [1,2,3] +-- @ +-- +-- You can perform IO by calling 'liftIO', and turn a 'Generator' into an +-- 'InputStream' with 'fromGenerator'. +-- +-- As a general rule, you should not acquire resources that need to be freed +-- from a 'Generator', because there is no guarantee the coroutine continuation +-- will ever be called, nor can you catch an exception from within a +-- 'Generator'. +newtype Generator r a = Generator { + unG :: IO (Either (SP r (Generator r a)) a) + } + + +------------------------------------------------------------------------------ +generatorBind :: Generator r a -> (a -> Generator r b) -> Generator r b +generatorBind (Generator m) f = Generator (m >>= either step value) + where + step (SP v r) = return $! Left $! SP v (generatorBind r f) + value = unG . f +{-# INLINE generatorBind #-} + + +------------------------------------------------------------------------------ +instance Monad (Generator r) where + return = Generator . return . Right + (>>=) = generatorBind + + +------------------------------------------------------------------------------ +instance MonadIO (Generator r) where + liftIO = Generator . (Right `fmap`) + + +------------------------------------------------------------------------------ +instance Functor (Generator r) where + fmap f (Generator m) = Generator $ m >>= either step value + where + step (SP v m') = return $! Left $! SP v (fmap f m') + value v = return $! Right $! f v + + +------------------------------------------------------------------------------ +instance Applicative (Generator r) where + pure = Generator . return . Right + + m <*> n = do + f <- m + v <- n + return $! f v + + +------------------------------------------------------------------------------ +-- | Calling @'yield' x@ causes the value @'Just' x@ to appear on the input +-- when this generator is converted to an 'InputStream'. The rest of the +-- computation after the call to 'yield' is resumed later when the +-- 'InputStream' is 'read' again. +yield :: r -> Generator r () +yield x = Generator $! return $! Left $! SP x (return $! ()) + + +------------------------------------------------------------------------------ +-- | Turns a 'Generator' into a 'Source' using the default pushback mechanism. +generatorToSource :: Generator r a -> Source r +generatorToSource (Generator m) = withDefaultPushback go + where + go = m >>= either step finish + finish = const $ return $! SP nullSource Nothing + step (SP v gen) = return $! SP (generatorToSource gen) (Just v) + + +------------------------------------------------------------------------------ +-- | Turns a 'Generator' into an 'InputStream'. +fromGenerator :: Generator r a -> IO (InputStream r) +fromGenerator (Generator m) = do + ref <- newIORef m + makeInputStream $! go ref + where + go ref = readIORef ref >>= (\n -> n >>= either step finish) + where + step (SP v gen) = do + writeIORef ref $! unG gen + return $! Just v + + finish _ = return Nothing + + +------------------------------------------------------------------------------ +newtype Consumer c a = Consumer { + unC :: IO (Either (Maybe c -> Consumer c a) a) + } + + +------------------------------------------------------------------------------ +instance Monad (Consumer c) where + return = Consumer . return . Right + + (Consumer m) >>= f = Consumer $ m >>= either step value + where + step g = return $! Left $! (>>= f) . g + value v = unC $ f v + + +------------------------------------------------------------------------------ +instance MonadIO (Consumer c) where + liftIO = Consumer . fmap Right + + +------------------------------------------------------------------------------ +instance Functor (Consumer r) where + fmap f (Consumer m) = Consumer (m >>= either step value) + where + step g = return $! Left $! (fmap f) . g + value v = return $! Right $! f v + + +------------------------------------------------------------------------------ +instance Applicative (Consumer r) where + pure = return + + m <*> n = do + f <- m + v <- n + return $! f v + + +------------------------------------------------------------------------------ +await :: Consumer r (Maybe r) +await = Consumer $ return (Left return) + + +------------------------------------------------------------------------------ +consumerToSink :: Consumer r a -> Sink r +consumerToSink (Consumer m) = Sink $ go m + where + go act v = act >>= either step value + where + value _ = return nullSink + step f = unC (f v) >>= + either (\g -> return $! Sink $! go (return $ Left g)) + (const $ return nullSink) + + +------------------------------------------------------------------------------ +fromConsumer :: Consumer r a -> IO (OutputStream r) +fromConsumer = sinkToStream . consumerToSink + + +------------------------------------------------------------------------------ +-- | A 'Sink' consumes values of type @c@ in the 'IO' monad. +-- +-- Sinks are supplied ordinary values by wrapping them in 'Just', and you +-- indicate the end of the stream to a 'Sink' by supplying 'Nothing'. +-- +-- If you supply a value after a 'Nothing', the behavior is defined by the +-- implementer of the given 'Sink'. (All 'Sink' definitions in this library +-- will simply discard the extra input.) +-- +-- Library users should use 'OutputStream's, which prevent reuse of previous +-- 'Sink's. +data Sink c = Sink { + consume :: Maybe c -> IO (Sink c) + } + + +------------------------------------------------------------------------------ +-- | appendSource concatenates two 'Source's, analogous to ('++') for lists. +-- +-- The second 'Source' continues where the first 'Source' ends. +-- +-- appendSource defines a monoid with 'nullSource' as the identity: +-- +-- > nullSource `appendSource` s = s +-- > +-- > s `appendSource` nullSource = s +-- > +-- > (s1 `appendSource` s2) `appendSource` s3 +-- > = s1 `appendSource` (s2 `appendSource` s3) +appendSource :: Source c -> Source c -> Source c +appendSource !p !q = Source prod pb + where + prod = do + (SP p' c) <- produce p + maybe (produce q) + (const $ return $! SP (p' `appendSource` q) c) + c + + pb c = do + s' <- pushback p c + return $! s' `appendSource` q + + +------------------------------------------------------------------------------ +instance Monoid (Source a) where + mempty = nullSource + mappend = appendSource + + +{- TODO: Define better convenience functions for pushback. These convenience + functions still require that the user ties the knot to correctly define + pushback, which is error-prone for non-trivial pushback + customizations. -} + +------------------------------------------------------------------------------ +-- | The default pushback implementation. Given a 'Source' and a value to push +-- back, produces a new 'Source' that will 'produce' the value given and yield +-- the original 'Source', and where 'pushback' recursively calls +-- 'defaultPushback'. +defaultPushback :: Source c -> c -> IO (Source c) +defaultPushback s c = let s' = Source { produce = return $! SP s (Just c) + , pushback = defaultPushback s' + } + in return $! s' + + +------------------------------------------------------------------------------ +-- | Given an action to use as 'produce', creates a 'Source' that uses +-- 'defaultPushback' as its 'pushback'. +withDefaultPushback :: IO (SP (Source c) (Maybe c)) -> Source c +withDefaultPushback prod = let s = Source prod (defaultPushback s) + in s + + +------------------------------------------------------------------------------ +-- | If you have just an @IO (Maybe c)@ action and are happy with the default +-- pushback behaviour, this function is slightly more efficient than +-- using 'withDefaultPushback'. (It allocates less.) +simpleSource :: IO (Maybe c) -> IO (Source c) +simpleSource m = newIORef [] >>= \ref -> + let s = Source prod pb + prod = pop ref >>= maybe prodM prodP + prodM = m >>= \x -> return $! + maybe (SP nullSource Nothing) (const $ SP s x) x + prodP c = return $! SP s (Just c) + pb c = modifyRef ref (c:) >> return s + in return $! s + + where + {-# INLINE pop #-} + pop ref = readIORef ref >>= \l -> + case l of + [] -> return Nothing + (x:xs) -> writeIORef ref xs >> (return $! Just x) + + +------------------------------------------------------------------------------ +{-# INLINE modifyRef #-} +modifyRef :: IORef a -> (a -> a) -> IO () +modifyRef ref f = do + x <- readIORef ref + writeIORef ref $! f x + + +------------------------------------------------------------------------------ +-- | An empty source that immediately yields 'Nothing'. +nullSource :: Source c +nullSource = withDefaultPushback (return $! SP nullSource Nothing) + + +------------------------------------------------------------------------------ +-- | 'nullSink' discards all values it consumes. +nullSink :: Sink c +nullSink = Sink $ const $ return nullSink + + +------------------------------------------------------------------------------ +-- | Transforms any value into a 1-element 'Source'. +singletonSource :: c -> Source c +singletonSource c = withDefaultPushback $ return $! SP nullSource (Just c) + + +------------------------------------------------------------------------------ +-- A note for readers: why are we using IORef inside InputStream and +-- OutputStream instead of MVar? +-- +-- A modifyMVar takes about 35ns to run on my Macbook, and the equivalent +-- readIORef/writeIORef pair takes 6ns. +-- +-- Given that we'll be composing these often, we'll give up thread safety in +-- order to gain a 6x performance improvement. If you want thread-safe access +-- to a stream, you can use lockingInputStream or lockingOutputStream. +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- | An 'InputStream' generates values of type @c@ in the 'IO' monad. +-- +-- Two primitive operations are defined on 'InputStream': +-- +-- * @'read' :: 'InputStream' c -> 'IO' ('Maybe' c)@ reads a value from the stream, +-- where \"end of stream\" is signaled by 'read' returning 'Nothing'. +-- +-- * @'unRead' :: c -> 'InputStream' c -> 'IO' ()@ \"pushes back\" a value to the +-- stream. +-- +-- It is intended that 'InputStream's obey the following law: +-- +-- @'unRead' c stream >> 'read' stream === 'return' ('Just' c)@ +-- +newtype InputStream c = IS (IORef (Source c)) + + +------------------------------------------------------------------------------ +-- | An 'OutputStream' consumes values of type @c@ in the 'IO' monad. +-- The only primitive operation defined on 'OutputStream' is: +-- +-- * @'write' :: 'Maybe' c -> 'OutputStream' c -> 'IO' ()@ +-- +-- Values of type @c@ are written in an 'OutputStream' by wrapping them in +-- 'Just', and the end of the stream is indicated by by supplying 'Nothing'. +-- +-- If you supply a value after a 'Nothing', the behavior is defined by the +-- implementer of the given 'OutputStream'. (All 'OutputStream' definitions in +-- this library will simply discard the extra input.) +-- +newtype OutputStream c = OS (IORef (Sink c)) + + +------------------------------------------------------------------------------ +-- | Reads one value from an 'InputStream'. +-- +-- Returns either a value wrapped in a 'Just', or 'Nothing' if the end of the +-- stream is reached. +read :: InputStream c -> IO (Maybe c) +read (IS ref) = do + m <- readIORef ref + SP m' x <- produce m + writeIORef ref m' + return x +{-# INLINE read #-} + + +------------------------------------------------------------------------------ +-- | Pushes a value back onto an input stream. 'read' and 'unRead' should +-- satisfy the following law, with the possible exception of side effects: +-- +-- @ +-- Streams.'unRead' c stream >> Streams.'read' stream === 'return' ('Just' c) +-- @ +-- +-- Note that this could be used to add values back to the stream that were not +-- originally drawn from the stream. +unRead :: c -> InputStream c -> IO () +unRead c (IS ref) = readIORef ref >>= f >>= writeIORef ref + where + f (Source _ pb) = pb c +{-# INLINE unRead #-} + + +------------------------------------------------------------------------------ +-- | Converts a 'Source' to an 'InputStream'. +sourceToStream :: Source a -> IO (InputStream a) +sourceToStream = liftM IS . newIORef +{-# INLINE sourceToStream #-} + + +------------------------------------------------------------------------------ +-- | Converts a 'Sink' to an 'OutputStream'. +sinkToStream :: Sink a -> IO (OutputStream a) +sinkToStream = liftM OS . newIORef +{-# INLINE sinkToStream #-} + + +------------------------------------------------------------------------------ +-- | 'concatInputStreams' concatenates a list of 'InputStream's, analogous to +-- ('++') for lists. +-- +-- Subsequent 'InputStream's continue where the previous one 'InputStream' +-- ends. +-- +-- Note: values pushed back to the 'InputStream' returned by +-- 'concatInputStreams' are not propagated to any of the source +-- 'InputStream's. +concatInputStreams :: [InputStream a] -> IO (InputStream a) +concatInputStreams inputStreams = do + ref <- newIORef inputStreams + makeInputStream $! run ref + + where + run ref = go + where + go = do + streams <- readIORef ref + case streams of + [] -> return Nothing + (s:rest) -> do + next <- read s + case next of + Nothing -> writeIORef ref rest >> go + Just _ -> return next + + +------------------------------------------------------------------------------ +-- | 'appendInputStream' concatenates two 'InputStream's, analogous to ('++') +-- for lists. +-- +-- The second 'InputStream' continues where the first 'InputStream' ends. +-- +-- Note: values pushed back to 'appendInputStream' are not propagated to either +-- wrapped 'InputStream'. +appendInputStream :: InputStream a -> InputStream a -> IO (InputStream a) +appendInputStream s1 s2 = concatInputStreams [s1, s2] + + +------------------------------------------------------------------------------ +-- | Observes the first value from an 'InputStream' without consuming it. +-- +-- Returns 'Nothing' if the 'InputStream' is empty. 'peek' satisfies the +-- following law: +-- +-- @ +-- Streams.'peek' stream >> Streams.'read' stream === Streams.'read' stream +-- @ +peek :: InputStream c -> IO (Maybe c) +peek s = do + x <- read s + maybe (return $! ()) (\c -> unRead c s) x + return x +{-# INLINE peek #-} + + +------------------------------------------------------------------------------ +-- | Feeds a value to an 'OutputStream'. Values of type @c@ are written in an +-- 'OutputStream' by wrapping them in 'Just', and the end of the stream is +-- indicated by by supplying 'Nothing'. +-- +write :: Maybe c -> OutputStream c -> IO () +write c (OS ref) = readIORef ref >>= (($ c) . consume) >>= writeIORef ref +{-# INLINE write #-} + + +------------------------------------------------------------------------------ +-- | Connects an 'InputStream' and 'OutputStream', supplying values from the +-- 'InputStream' to the 'OutputStream', and propagating the end-of-stream +-- message from the 'InputStream' through to the 'OutputStream'. +-- +-- The connection ends when the 'InputStream' yields a 'Nothing'. +connect :: InputStream a -> OutputStream a -> IO () +connect p q = loop + where + loop = do + m <- read p + maybe (write Nothing q) + (const $ write m q >> loop) + m +{-# INLINE connect #-} + + +------------------------------------------------------------------------------ +-- | The 'connectTo' function is just @'flip' 'connect'@. +-- +-- Useful for writing expressions like @fromList [1,2,3] >>= connectTo foo@. +-- +connectTo :: OutputStream a -> InputStream a -> IO () +connectTo = flip connect +{-# INLINE connectTo #-} + + +------------------------------------------------------------------------------ +-- | Connects an 'InputStream' to an 'OutputStream' without passing the +-- end-of-stream notification through to the 'OutputStream'. +-- +-- Use this to supply an 'OutputStream' with multiple 'InputStream's and use +-- 'connect' for the final 'InputStream' to finalize the 'OutputStream', like +-- so: +-- +-- @ +-- do Streams.'supply' input1 output +-- Streams.'supply' input2 output +-- Streams.'connect' input3 output +-- @ +-- +supply :: InputStream a -> OutputStream a -> IO () +supply p q = loop + where + loop = do + m <- read p + maybe (return $! ()) + (const $ write m q >> loop) + m +{-# INLINE supply #-} + + +------------------------------------------------------------------------------ +-- | 'supply' with the arguments flipped. +supplyTo :: OutputStream a -> InputStream a -> IO () +supplyTo = flip supply +{-# INLINE supplyTo #-} + + +------------------------------------------------------------------------------ +-- | Creates an 'InputStream' from a value-producing action. +-- +-- (@makeInputStream m@) calls the action @m@ each time you request a value +-- from the 'InputStream'. The given action is extended with the default +-- pushback mechanism (see "System.IO.Streams.Internal#pushback"). +makeInputStream :: IO (Maybe a) -> IO (InputStream a) +makeInputStream = simpleSource >=> sourceToStream +{-# INLINE makeInputStream #-} + + +------------------------------------------------------------------------------ +-- | Creates an 'OutputStream' from a value-consuming action. +-- +-- (@makeOutputStream f@) runs the computation @f@ on each value fed to it. +makeOutputStream :: (Maybe a -> IO ()) -> IO (OutputStream a) +makeOutputStream f = sinkToStream s + where + s = Sink (\x -> f x >> return s) +{-# INLINE makeOutputStream #-} + + +------------------------------------------------------------------------------ +-- | Converts an 'InputStream' into a thread-safe 'InputStream', at a slight +-- performance penalty. +-- +-- For performance reasons, this library provides non-thread-safe streams by +-- default. Use the @locking@ functions to convert these streams into slightly +-- slower, but thread-safe, equivalents. +lockingInputStream :: InputStream a -> IO (InputStream a) +lockingInputStream s = do + mv <- newMVar $! () + let src = Source { produce = withMVar mv $ const $ do + x <- read s + return $! SP src x + , pushback = \c -> withMVar mv $ const $ do + unRead c s + return src + } + sourceToStream src +{-# INLINE lockingInputStream #-} + + +------------------------------------------------------------------------------ +-- | Converts an 'OutputStream' into a thread-safe 'OutputStream', at a slight +-- performance penalty. +-- +-- For performance reasons, this library provides non-thread-safe streams by +-- default. Use the @locking@ functions to convert these streams into slightly +-- slower, but thread-safe, equivalents. +lockingOutputStream :: OutputStream a -> IO (OutputStream a) +lockingOutputStream s = do + mv <- newMVar $! () + makeOutputStream $ f mv + + where + f mv x = withMVar mv $ const $ write x s +{-# INLINE lockingOutputStream #-} + + +------------------------------------------------------------------------------ +-- | An empty 'InputStream' that yields 'Nothing' immediately. +nullInput :: IO (InputStream a) +nullInput = sourceToStream nullSource + + +------------------------------------------------------------------------------ +-- | An empty 'OutputStream' that discards any input fed to it. +nullOutput :: IO (OutputStream a) +nullOutput = sinkToStream nullSink + + +------------------------------------------------------------------------------ +-- | Checks if an 'InputStream' is at end-of-stream. +atEOF :: InputStream a -> IO Bool +atEOF s = read s >>= maybe (return True) (\k -> unRead k s >> return False) + + +------------------------------------------------------------------------------ +-- $pushback +-- #pushback# +-- +-- Users can push a value back into an input stream using the 'unRead' +-- function. Usually this will use the default pushback mechanism which +-- provides a buffer for the stream. Some stream transformers, like +-- 'takeBytes', produce streams that send pushed-back values back to the +-- streams that they wrap. A function like 'System.IO.Streams.Combinators.map' +-- cannot do this because the types don't match up: +-- +-- @ +-- 'System.IO.Streams.Combinators.map' :: (a -> b) -> 'InputStream' a -> 'IO' ('InputStream' b) +-- @ +-- +-- A function will usually document if its pushback behaviour differs from the +-- default. No matter what the case, input streams should obey the following +-- law: +-- +-- @ +-- Streams.'unRead' c stream >> Streams.'read' stream === 'return' ('Just' c) +-- @ diff --git a/src/System/IO/Streams/Internal/Attoparsec.hs b/src/System/IO/Streams/Internal/Attoparsec.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Internal/Attoparsec.hs @@ -0,0 +1,130 @@ +-- | This module provides support for parsing values from 'InputStream's using +-- @attoparsec@. + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +module System.IO.Streams.Internal.Attoparsec + ( -- * Parsing + ParseException(..) + , parseFromStream + , parseFromStreamInternal + , parserToInputStream + ) where + +------------------------------------------------------------------------------ +import Control.Exception (Exception, throwIO) +import Control.Monad (when) +import Data.Attoparsec.ByteString.Char8 (IResult (..), Parser, + Result, eitherResult, feed, + parse) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import Data.Typeable (Typeable) +import Prelude hiding (read) +------------------------------------------------------------------------------ +import System.IO.Streams.Internal (InputStream) +import qualified System.IO.Streams.Internal as Streams + +------------------------------------------------------------------------------ +-- | An exception raised when parsing fails. +data ParseException = ParseException String + deriving (Typeable) + +instance Show ParseException where + show (ParseException s) = "Parse exception: " ++ s + +instance Exception ParseException + +------------------------------------------------------------------------------ +-- | Supplies an @attoparsec@ 'Parser' with an 'InputStream', returning the +-- final parsed value or a 'ParseException' if parsing fails. +-- +-- 'parseFromStream' consumes only as much input as necessary to satisfy the +-- 'Parser' and unconsumed input is pushed back onto the 'InputStream'. +-- +-- If the 'Parser' exhausts the 'InputStream', it receives an @EOF@. +-- +-- Example: +-- +-- @ +-- ghci> import "Data.Attoparsec.ByteString.Char8" +-- ghci> is <- 'System.IO.Streams.fromList' [\"12345xxx\" :: 'ByteString'] +-- ghci> 'parseFromStream' ('Data.Attoparsec.ByteString.Char8.takeWhile' 'Data.Attoparsec.ByteString.Char8.isDigit') is +-- \"12345\" +-- ghci> 'System.IO.Streams.read' is +-- Just \"xxx\" +-- @ +parseFromStream :: Parser r + -> InputStream ByteString + -> IO r +parseFromStream = parseFromStreamInternal parse feed +{-# INLINE parseFromStream #-} + + +------------------------------------------------------------------------------ +-- | Internal version of parseFromStream allowing dependency injection of the +-- parse functions for testing. +parseFromStreamInternal :: (Parser r -> ByteString -> Result r) + -> (Result r -> ByteString -> Result r) + -> Parser r + -> InputStream ByteString + -> IO r +parseFromStreamInternal parseFunc feedFunc parser is = + Streams.read is >>= + maybe (finish $ parseFunc parser "") + (\s -> if S.null s + then parseFromStreamInternal parseFunc feedFunc parser is + else go $! parseFunc parser s) + where + leftover x = when (not $ S.null x) $ Streams.unRead x is + + finish k = let k' = feedFunc (feedFunc k "") "" + in case k' of + Fail x _ _ -> leftover x >> err k' + Partial _ -> err k' -- should be impossible + Done x r -> leftover x >> return r + + err r = let (Left s) = eitherResult r in throwIO $ ParseException s + + go r@(Fail x _ _) = leftover x >> err r + go (Done x r) = leftover x >> return r + go r = Streams.read is >>= + maybe (finish r) + (\s -> if S.null s + then go r + else go $! feedFunc r s) + + +------------------------------------------------------------------------------ +-- | Given a 'Parser' yielding values of type @'Maybe' r@, transforms an +-- 'InputStream' over byte strings to an 'InputStream' yielding values of type +-- @r@. +-- +-- If the parser yields @Just x@, then @x@ will be passed along downstream, and +-- if the parser yields @Nothing@, that will be interpreted as end-of-stream. +-- +-- Upon a parse error, 'parserToInputStream' will throw a 'ParseException'. +-- +-- Example: +-- +-- @ +-- ghci> import "Control.Applicative" +-- ghci> import "Data.Attoparsec.ByteString.Char8" +-- ghci> is <- 'System.IO.Streams.fromList' [\"1 2 3 4 5\" :: 'ByteString'] +-- ghci> let parser = ('Data.Attoparsec.ByteString.Char8.endOfInput' >> 'Control.Applicative.pure' 'Nothing') \<|\> (Just \<$\> ('Data.Attoparsec.ByteString.Char8.skipWhile' 'Data.Attoparsec.ByteString.Char8.isSpace' *> 'Data.Attoparsec.ByteString.Char8.decimal')) +-- ghci> 'parserToInputStream' parser is >>= 'System.IO.Streams.toList' +-- [1,2,3,4,5] +-- ghci> is' \<- 'System.IO.Streams.fromList' [\"1 2xx3 4 5\" :: 'ByteString'] >>= 'parserToInputStream' parser +-- ghci> 'read' is' +-- Just 1 +-- ghci> 'read' is' +-- Just 2 +-- ghci> 'read' is' +-- *** Exception: Parse exception: Failed reading: takeWhile1 +-- @ +parserToInputStream :: Parser (Maybe r) + -> InputStream ByteString + -> IO (InputStream r) +parserToInputStream = (Streams.makeInputStream .) . parseFromStream +{-# INLINE parserToInputStream #-} diff --git a/src/System/IO/Streams/Internal/Search.hs b/src/System/IO/Streams/Internal/Search.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Internal/Search.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module System.IO.Streams.Internal.Search + ( search + , MatchInfo(..) + ) where + +------------------------------------------------------------------------------ +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import Data.ByteString.Unsafe as S +import Data.Monoid (mappend, mconcat) +import qualified Data.Vector.Unboxed as V +import qualified Data.Vector.Unboxed.Mutable as MV +import Prelude hiding (last, read) +------------------------------------------------------------------------------ +import System.IO.Streams.Internal (InputStream, SP (..), + nullSource, produce, read, + singletonSource, sourceToStream, + withDefaultPushback) + +------------------------------------------------------------------------------ +-- | 'MatchInfo' provides match information when performing string search. +data MatchInfo = Match {-# UNPACK #-} !ByteString + | NoMatch {-# UNPACK #-} !ByteString + deriving (Show, Eq) + + +------------------------------------------------------------------------------ +-- | Does the given needle match the haystack over the given ranges of indices? +matches :: ByteString -- ^ needle + -> Int -- ^ needle start + -> Int -- ^ needle end (inclusive) + -> ByteString -- ^ haystack + -> Int -- ^ haystack start + -> Int -- ^ haystack end (inclusive) + -> Bool +matches !needle !nstart !nend' !haystack !hstart !hend' = + go nend' hend' + where + go !nend !hend = + if nend < nstart || hend < hstart + then True + else let !nc = S.unsafeIndex needle nend + !hc = S.unsafeIndex haystack hend + in if nc /= hc + then False + else go (nend-1) (hend-1) +{-# INLINE matches #-} + + +------------------------------------------------------------------------------ +-- | Given a 'ByteString' to look for (the \"needle\") and an 'InputStream', +-- produces a new 'InputStream' which yields data of type 'MatchInfo'. +-- +-- Example: +-- +-- @ +-- ghci> 'System.IO.Streams.fromList' [\"food\", \"oof\", \"oodles\", \"ok\"] >>= +-- 'search' \"foo\" >>= 'System.IO.Streams.toList' +-- ['Match' \"foo\",'NoMatch' \"d\",'NoMatch' \"oo\",'Match' \"foo\",'NoMatch' \"dlesok\"] +-- @ +-- +-- Uses the Boyer-Moore-Horspool algorithm +-- (). +search :: ByteString -- ^ \"needle\" to look for + -> InputStream ByteString -- ^ input stream to wrap + -> IO (InputStream MatchInfo) +search needle stream = do + --debug $ "boyermoore: needle=" ++ show needle + sourceToStream (withDefaultPushback $ + lookahead nlen >>= either finishAndEOF startSearch) + + where + -------------------------------------------------------------------------- + finishAndEOF x = if S.null x + then return $! SP nullSource Nothing + else return $! SP nullSource (Just $! NoMatch x) + + -------------------------------------------------------------------------- + startSearch !haystack = + if S.null haystack + then lookahead nlen >>= either finishAndEOF startSearch + else go 0 + + where + ---------------------------------------------------------------------- + !hlen = S.length haystack + + ---------------------------------------------------------------------- + go !hidx + | hend >= hlen = crossBound hidx + | otherwise = do + let match = matches needle 0 last haystack hidx hend + if match + then do + let !nomatch = S.take hidx haystack + let !aftermatch = S.drop (hend + 1) haystack + + produceMatch nomatch aftermatch + else do + -- skip ahead + let c = S.unsafeIndex haystack hend + let !skip = V.unsafeIndex table $ fromEnum c + go (hidx + skip) + + where + !hend = hidx + nlen - 1 + + ---------------------------------------------------------------------- + mkCoeff hidx = let !ll = hlen - hidx + !nm = nlen - ll + in (ll, nm) + + ---------------------------------------------------------------------- + crossBound !hidx0 = do + let (!leftLen, needMore) = mkCoeff hidx0 + + lookahead needMore >>= + either (\s -> finishAndEOF $ S.append haystack s) + (runNext hidx0 leftLen needMore) + + where + runNext !hidx !leftLen !needMore !nextHaystack = do + let match1 = matches needle leftLen last nextHaystack 0 + (needMore-1) + let match2 = matches needle 0 (leftLen-1) haystack hidx + (hlen-1) + + if match1 && match2 + then do + let !nomatch = S.take hidx haystack + let !aftermatch = S.drop needMore nextHaystack + + produceMatch nomatch aftermatch + + else do + let c = S.unsafeIndex nextHaystack $ needMore - 1 + let p = V.unsafeIndex table (fromEnum c) + + if p < leftLen + then do + let !hidx' = hidx + p + let (!leftLen', needMore') = mkCoeff hidx' + let !nextlen = S.length nextHaystack + if nextlen < needMore' + then + -- this should be impossibly rare + lookahead (needMore' - nextlen) >>= + either (\s -> finishAndEOF $ + S.concat [ haystack + , nextHaystack + , s ]) + (\s -> runNext hidx' leftLen' needMore' $ + S.append nextHaystack s) + else runNext hidx' leftLen' needMore' nextHaystack + else do + let sidx = p - leftLen + let (!crumb, rest) = S.splitAt sidx nextHaystack + let s1 = singletonSource $ NoMatch $ + S.concat [haystack, crumb] + let s2 = withDefaultPushback $ startSearch rest + produce $ s1 `mappend` s2 + + -------------------------------------------------------------------------- + produceMatch nomatch aftermatch = do + let !s1 = singletonSource $! NoMatch nomatch + let !s2 = singletonSource $! Match needle + let s3 = withDefaultPushback $ startSearch aftermatch + + produce $ mconcat $ if S.null nomatch + then [s2, s3] + else [s1, s2, s3] + + + -------------------------------------------------------------------------- + !nlen = S.length needle + !last = nlen - 1 + + -------------------------------------------------------------------------- + !table = V.create $ do + t <- MV.replicate 256 nlen + go t + + where + go !t = go' 0 + where + go' !i | i >= last = return t + | otherwise = do + let c = fromEnum $ S.unsafeIndex needle i + MV.unsafeWrite t c (last - i) + go' $! i+1 + + -------------------------------------------------------------------------- + lookahead n = go id n + where + go dlist !k = read stream >>= maybe eof chunk + where + eof = return $! Left $! S.concat $ dlist [] + + chunk x = if r <= 0 + then return $! Right $! S.concat $ d' [] + else go d' r + where + l = S.length x + r = k - l + d' = dlist . (x:) diff --git a/src/System/IO/Streams/List.hs b/src/System/IO/Streams/List.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/List.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE BangPatterns #-} + +-- | List conversions and utilities. + +module System.IO.Streams.List + ( -- * List conversions + fromList + , toList + , outputToList + , writeList + + -- * Utility + , chunkList + , concatLists + , listOutputStream + ) where + +import Control.Concurrent.MVar (modifyMVar, modifyMVar_, newMVar) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.IORef (newIORef, readIORef, writeIORef) +import Prelude hiding (read) +import System.IO.Streams.Internal (InputStream, OutputStream,Sink (..), connect, fromGenerator, + makeInputStream, nullSink, + read, sinkToStream, + write, yield) + + +------------------------------------------------------------------------------ +-- | Transforms a list into an 'InputStream' that produces no side effects. +-- +-- @ +-- ghci> is <- Streams.'fromList' [1, 2] +-- ghci> 'replicateM' 3 (Streams.'read' is) +-- [Just 1, Just 2, Nothing] +-- @ +fromList :: [c] -> IO (InputStream c) +fromList inp = newIORef inp >>= makeInputStream . f + where + f ref = readIORef ref >>= \l -> + case l of + [] -> return Nothing + (x:xs) -> writeIORef ref xs >> return (Just x) +{-# INLINE fromList #-} + + +------------------------------------------------------------------------------ +-- | 'listOutputStream' returns an 'OutputStream' which stores values fed into +-- it and an action which flushes all stored values to a list. +-- +-- The flush action resets the store. +-- +-- Note that this function /will/ buffer any input sent to it on the heap. +-- Please don't use this unless you're sure that the amount of input provided +-- is bounded and will fit in memory without issues. +-- +-- @ +-- ghci> (os, flush) <- Streams.'listOutputStream' :: IO ('OutputStream' Int, IO [Int]) +-- ghci> Streams.'writeList' [1, 2] os +-- ghci> flush +-- [1, 2] +-- ghci> Streams.'writeList' [3, 4] os +-- ghci> flush +-- [3, 4] +-- @ +listOutputStream :: IO (OutputStream c, IO [c]) +listOutputStream = do + r <- newMVar id + c <- sinkToStream $ consumer r + return (c, flush r) + + where + consumer r = go + where + go = Sink $ maybe (return nullSink) + (\c -> do + modifyMVar_ r $ \dl -> return (dl . (c:)) + return go) + + flush r = modifyMVar r $ \dl -> return (id, dl []) +{-# INLINE listOutputStream #-} + + +------------------------------------------------------------------------------ +-- | Drains an 'InputStream', converting it to a list. N.B. that this function +-- reads the entire 'InputStream' strictly into memory and as such is not +-- recommended for streaming applications or where the size of the input is not +-- bounded or known. +-- +-- @ +-- ghci> is <- Streams.'fromList' [1, 2] +-- ghci> Streams.'toList' is +-- [1, 2] +-- @ +toList :: InputStream a -> IO [a] +toList is = outputToList (connect is) +{-# INLINE toList #-} + + +------------------------------------------------------------------------------ +-- | Given an IO action that requires an 'OutputStream', creates one and +-- captures all the output the action sends to it as a list. +-- +-- Example: +-- +-- @ +-- ghci> import "Control.Applicative" +-- ghci> ('connect' <$> 'fromList' [\"a\", \"b\", \"c\"]) >>= 'outputToList' +-- ["a","b","c"] +-- @ +outputToList :: (OutputStream a -> IO b) -> IO [a] +outputToList f = do + (os, getList) <- listOutputStream + _ <- f os + getList +{-# INLINE outputToList #-} + + +------------------------------------------------------------------------------ +-- | Feeds a list to an 'OutputStream'. Does /not/ write an end-of-stream to +-- the stream. +-- +-- @ +-- ghci> os \<- Streams.'unlines' Streams.'System.IO.Streams.stdout' >>= Streams.'System.IO.Streams.contramap' (S.pack . show) :: IO ('OutputStream' Int) +-- ghci> Streams.'writeList' [1, 2] os +-- 1 +-- 2 +-- ghci> Streams.'writeList' [3, 4] os +-- 3 +-- 4 +-- @ +writeList :: [a] -> OutputStream a -> IO () +writeList xs os = mapM_ (flip write os . Just) xs +{-# INLINE writeList #-} + + +------------------------------------------------------------------------------ +-- | Splits an input stream into chunks of at most size @n@. +-- +-- Example: +-- +-- @ +-- ghci> 'fromList' [1..14::Int] >>= 'chunkList' 4 >>= 'toList' +-- [[1,2,3,4],[5,6,7,8],[9,10,11,12],[13,14]] +-- @ +chunkList :: Int -- ^ chunk size + -> InputStream a -- ^ stream to process + -> IO (InputStream [a]) +chunkList n input = if n <= 0 + then error $ "chunkList: bad size: " ++ show n + else fromGenerator $ go n id + where + go !k dl | k <= 0 = yield (dl []) >> go n id + | otherwise = do + liftIO (read input) >>= maybe finish chunk + where + finish = let l = dl [] + in if null l then return $! () else yield l + chunk x = go (k - 1) (dl . (x:)) + + +------------------------------------------------------------------------------ +-- | Given an input stream containing lists, produces a new input stream that +-- will yield the concatenation of these lists. See 'Prelude.concat'. +-- +-- Example: +-- +-- @ +-- ghci> Streams.'fromList' [[1,2,3::Int], [4,5,6]] >>= +-- Streams.'concatLists' >>= +-- Streams.'toList' +-- [1,2,3,4,5,6] +-- @ +concatLists :: InputStream [a] -> IO (InputStream a) +concatLists input = fromGenerator go + where + go = liftIO (read input) >>= maybe (return $! ()) chunk + chunk l = sequence_ (map yield l) >> go diff --git a/src/System/IO/Streams/Network.hs b/src/System/IO/Streams/Network.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Network.hs @@ -0,0 +1,35 @@ +-- | Converting network 'Socket's to streams. +module System.IO.Streams.Network + ( -- * Sockets to Streams + socketToStreams + ) where + +------------------------------------------------------------------------------ +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import Network.Socket (Socket) +import qualified Network.Socket.ByteString as N +import System.IO.Streams.Internal (InputStream, OutputStream) +import qualified System.IO.Streams.Internal as Streams + + +------------------------------------------------------------------------------ +-- | Converts a 'Socket' to an 'InputStream' \/ 'OutputStream' pair. Note that, +-- as is usually the case in @io-streams@, writing a 'Nothing' to the generated +-- 'OutputStream' does not cause the underlying 'Socket' to be closed. +socketToStreams :: Socket + -> IO (InputStream ByteString, OutputStream ByteString) +socketToStreams socket = do + is <- Streams.makeInputStream input + os <- Streams.makeOutputStream output + return $! (is, os) + + where + bUFSIZ = 32752 + + input = do + s <- N.recv socket bUFSIZ + return $! if S.null s then Nothing else Just s + + output Nothing = return $! () + output (Just s) = if S.null s then return $! () else N.sendAll socket s diff --git a/src/System/IO/Streams/Text.hs b/src/System/IO/Streams/Text.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Text.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Stream primitives for decoding and encoding 'Text' values in UTF-8 format. +module System.IO.Streams.Text + ( -- * Decoders and Encoders + decodeUtf8 + , decodeUtf8With + , encodeUtf8 + ) where + +------------------------------------------------------------------------------ +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Unsafe as S +import Data.Monoid (mappend) +import Data.Text (Text) +import qualified Data.Text.Encoding as T +import Data.Text.Encoding.Error (OnDecodeError) +import Data.Word (Word8) +------------------------------------------------------------------------------ +import qualified System.IO.Streams.Combinators as Streams +import System.IO.Streams.Internal (InputStream, OutputStream) +import qualified System.IO.Streams.Internal as Streams + + +------------------------------------------------------------------------------ +-- | Convert an 'OutputStream' taking 'ByteString's to an 'OutputStream' that +-- takes 'Text', encoding the data as UTF-8. See +-- @Data.Text.Encoding.'T.encodeUtf8'@. +encodeUtf8 :: OutputStream ByteString -> IO (OutputStream Text) +encodeUtf8 = Streams.contramap T.encodeUtf8 + + +------------------------------------------------------------------------------ +-- | Decode an 'InputStream' of 'ByteString's in UTF-8 format into an +-- 'InputStream' of 'Text' values. If decoding fails, will throw an exception. +-- See @Data.Text.Encoding.'T.decodeUtf8'@. +decodeUtf8 :: InputStream ByteString -> IO (InputStream Text) +decodeUtf8 = decode T.decodeUtf8 +{-# INLINE decodeUtf8 #-} + + +------------------------------------------------------------------------------ +-- | Decode an 'InputStream' of 'ByteString's in UTF-8 format into an +-- 'InputStream' of 'Text' values. If decoding fails, invokes the given +-- 'OnDecodeError' function to decide what to do. See +-- @Data.Text.Encoding.'T.decodeUtf8With'@. +decodeUtf8With :: OnDecodeError + -> InputStream ByteString + -> IO (InputStream Text) +decodeUtf8With e = decode (T.decodeUtf8With e) +{-# INLINE decodeUtf8With #-} + + +------------------------------------------------------------------------------ +decode :: (ByteString -> Text) + -> InputStream ByteString + -> IO (InputStream Text) +decode decodeFunc input = Streams.fromGenerator $ go Nothing + where + go !soFar = liftIO (Streams.read input) >>= + maybe (finish soFar) (chunk soFar) + + finish Nothing = return $! () + finish (Just x) = Streams.yield $! decodeFunc x + + chunk Nothing s = process s + chunk (Just a) b = process $ a `mappend` b + + process !s = + case findLastFullCode s of + LastCodeIsComplete x -> (Streams.yield $! decodeFunc x) >> go Nothing + Split a b -> do + when (not $ S.null a) $ + Streams.yield $! decodeFunc a + go (Just b) + NoCodesAreComplete x -> go (Just x) + + +------------------------------------------------------------------------------ +data ByteType = Regular + | Continuation + | Start !Int + + +------------------------------------------------------------------------------ +between :: Word8 -> Word8 -> Word8 -> Bool +between x y z = x >= y && x <= z +{-# INLINE between #-} + + +------------------------------------------------------------------------------ +characterizeByte :: Word8 -> ByteType +characterizeByte c | between c 0 0x7F = Regular + | between c 0x80 0xBF = Continuation + | between c 0xC0 0xDF = Start 1 + | between c 0xE0 0xEF = Start 2 + -- Technically utf-8 ends after 0xf4, but those sequences + -- won't decode anyways. + | otherwise = Start 3 + + +------------------------------------------------------------------------------ +data FindOutput = LastCodeIsComplete !ByteString + | Split !ByteString !ByteString + | NoCodesAreComplete !ByteString -- should be impossibly rare + -- in real data + + +------------------------------------------------------------------------------ +findLastFullCode :: ByteString -> FindOutput +findLastFullCode b | len == 0 = LastCodeIsComplete b + | otherwise = go + where + len = S.length b + + go = let !idx = len - 1 + !c = S.unsafeIndex b idx + in case characterizeByte c of + Regular -> LastCodeIsComplete b + Continuation -> cont (len - 2) + _ -> Split (S.unsafeTake idx b) (S.unsafeDrop idx b) + + cont !idx | idx < 0 = NoCodesAreComplete b + | otherwise = + let !c = S.unsafeIndex b idx + in case characterizeByte c of + -- what do we do with this? decoding will fail. give up + -- and lie, the text decoder will deal with it.. + Regular -> LastCodeIsComplete b + Continuation -> cont (idx - 1) + Start n -> if n + idx == len - 1 + then LastCodeIsComplete b + else Split (S.unsafeTake idx b) + (S.unsafeDrop idx b) +{-# INLINE findLastFullCode #-} diff --git a/src/System/IO/Streams/Tutorial.hs b/src/System/IO/Streams/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Tutorial.hs @@ -0,0 +1,441 @@ +module System.IO.Streams.Tutorial ( + -- * Introduction + -- $introduction + + -- * Build Input Streams + -- $createinput + + -- * Build Output Streams + -- $createoutput + + -- * Connect Streams + -- $connect + + -- * Transform Streams + -- $transform + + -- * Resource and Exception Safety + -- $safety + + -- * Pushback + -- $pushback + + -- * Thread Safety + -- $threadsafety + + -- * Examples + -- $examples + ) where + +{- $introduction + +The @io-streams@ package defines two \"smart handles\" for stream processing: + + * 'System.IO.Streams.InputStream': a read-only smart handle + + * 'System.IO.Streams.OutputStream': a write-only smart handle + +The 'System.IO.Streams.InputStream' type implements all the core operations we +expect for a read-only handle. We consume values using 'read', which returns a +'Nothing' when the resource is done: + +@ +'System.IO.Streams.read' :: 'System.IO.Streams.InputStream' c -> 'IO' ('Maybe' c) +@ + +... and we can push back values using 'System.IO.Streams.unRead': + +@ +'System.IO.Streams.unRead' :: c -> 'System.IO.Streams.InputStream' c -> 'IO' () +@ + +The 'System.IO.Streams.OutputStream' type implements the +'System.IO.Streams.write' operation which feeds it output, supplying 'Nothing' +to signal resource exhaustion: + +@ +'System.IO.Streams.write' :: 'Maybe' c -> 'System.IO.Streams.OutputStream' c -> 'IO' () +@ + +These streams slightly resemble Haskell 'System.IO.Handle's, but support a +wider range of sources and sinks. For example, you can convert an ordinary list +to an 'System.IO.Streams.InputStream' source and interact with it using the +handle-based API: + +@ +ghci> import qualified System.IO.Streams as S +ghci> listHandle \<- S.'System.IO.Streams.fromList' [1, 2] +ghci> S.'System.IO.Streams.read' listHandle +Just 1 +ghci> S.'System.IO.Streams.read' listHandle +Just 2 +ghci> S.'System.IO.Streams.read' listHandle +Nothing +@ + +Additionally, IO streams come with a library of stream transformations that +preserve their handle-like API. For example, you can map a function over an +'System.IO.Streams.InputStream', which generates a new handle to the same +stream that returns transformed values: + +@ +ghci> oldHandle \<- S.'System.IO.Streams.List.fromList' [1, 2, 3] +ghci> newHandle \<- S.'System.IO.Streams.Combinators.mapM' (\\x -\> 'return' (x * 10)) oldHandle +ghci> S.'System.IO.Streams.read' newHandle +10 +ghci> -- We can still view the stream through the old handle +ghci> S.'System.IO.Streams.read' oldHandle +2 +ghci> -- ... and switch back again +ghci> S.'System.IO.Streams.read' newHandle +30 +@ + +IO streams focus on preserving the convention of traditional handles while +offering a wider library of stream-processing utilities. + +-} + +{- $createinput + + +The @io-streams@ library provides a simple interface for creating your own +'System.IO.Streams.InputStream's and 'System.IO.Streams.OutputStream's. + +You can build an 'System.IO.Streams.InputStream' from any 'IO' action that +generates output, as long as it wraps results in 'Just' and uses 'Nothing' to +signal EOF: + +@ +'System.IO.Streams.makeInputStream' :: 'IO' ('Maybe' a) -> 'IO' ('System.IO.Streams.InputStream' a) +@ + +As an example, let's wrap an ordinary read-only 'System.IO.Handle' in an +'System.IO.Streams.InputStream': + +@ +import "Data.ByteString" ('Data.ByteString.ByteString') +import qualified "Data.ByteString" as S +import "System.IO.Streams" ('System.IO.Streams.InputStream') +import qualified "System.IO.Streams" as Streams +import "System.IO" ('System.IO.Handle', 'System.IO.hFlush') + +bUFSIZ = 32752 + +upgradeReadOnlyHandle :: 'System.IO.Handle' -> 'IO' ('System.IO.Streams.InputStream' 'Data.ByteString.ByteString') +upgradeReadOnlyHandle h = Streams.'System.IO.Streams.makeInputStream' f + where + f = do + x <- S.'Data.ByteString.hGetSome' h bUFSIZ + 'return' $! if S.'Data.ByteString.null' x then 'Nothing' else 'Just' x +@ + +We didn't even really need to write the @upgradeReadOnlyHandle@ function, +because "System.IO.Streams.Handle" already provides one that uses the exact +same implementation given above: + +@ +'System.IO.Streams.handleToInputStream' :: 'System.IO.Handle' -> 'IO' ('System.IO.Streams.InputStream' 'Data.ByteString.ByteString') +@ + +-} + +{- $createoutput + +Similarly, you can build any 'System.IO.Streams.OutputStream' from an 'IO' +action that accepts input, as long as it interprets 'Just' as more input and +'Nothing' as EOF: + +@ +'System.IO.Streams.makeOutputStream' :: ('Maybe' a -> 'IO' ()) -> 'IO' ('System.IO.Streams.OutputStream' a) +@ + +A simple 'System.IO.Streams.OutputStream' might wrap 'putStrLn' for 'Data.ByteString.ByteString's: + +@ +import "Data.ByteString" ('Data.ByteString.ByteString') +import qualified "Data.ByteString" as S +import "System.IO.Streams" ('System.IO.Streams.OutputStream') +import qualified "System.IO.Streams" as Streams +\ +writeConsole :: 'IO' ('System.IO.Streams.OutputStream' 'Data.ByteString.ByteString') +writeConsole = Streams.'System.IO.Streams.makeOutputStream' $ \\m -> case m of + 'Just' bs -> S.'Data.ByteString.putStrLn' bs + 'Nothing' -> 'return' () +@ + +The 'Just' wraps more incoming data, whereas 'Nothing' indicates the data is +exhausted. In principle, you can feed 'System.IO.Streams.OutputStream's more +input after writing a 'Nothing' to them, but IO streams only guarantee a +well-defined behavior up to the first 'Nothing'. After receiving the first +'Nothing', an 'System.IO.Streams.OutputStream' could respond to additional +input by: + + * Using the input + + * Ignoring the input + + * Throwing an exception + +Ideally, you should adhere to well-defined behavior and ensure that after you +write a 'Nothing' to an 'System.IO.Streams.OutputStream', you don't write +anything else. + +-} + +{- $connect + +@io-streams@ provides two ways to connect an 'System.IO.Streams.InputStream' +and 'System.IO.Streams.OutputStream': + +@ +'System.IO.Streams.connect' :: 'System.IO.Streams.InputStream' a -> 'System.IO.Streams.OutputStream' a -> 'IO' () +'System.IO.Streams.supply' :: 'System.IO.Streams.InputStream' a -> 'System.IO.Streams.OutputStream' a -> 'IO' () +@ + +'System.IO.Streams.connect' feeds the 'System.IO.Streams.OutputStream' +exclusively with the given 'System.IO.Streams.InputStream' and passes along the +end-of-stream notification to the 'System.IO.Streams.OutputStream'. + +'System.IO.Streams.supply' feeds the 'System.IO.Streams.OutputStream' +non-exclusively with the given 'System.IO.Streams.InputStream' and does not +pass along the end-of-stream notification to the +'System.IO.Streams.OutputStream'. + +You can combine both 'System.IO.Streams.supply' and 'System.IO.Streams.connect' +to feed multiple 'System.IO.Streams.InputStream's into a single +'System.IO.Streams.OutputStream': + +@ +import qualified "System.IO.Streams" as Streams +import "System.IO" ('System.IO.IOMode'('System.IO.WriteMode')) + +main = do + Streams.'System.IO.Streams.withFileAsOutput' \"out.txt\" 'System.IO.WriteMode' $ \\outStream -> + Streams.'System.IO.Streams.withFileAsInput' \"in1.txt\" $ \\inStream1 -> + Streams.'System.IO.Streams.withFileAsInput' \"in2.txt\" $ \\inStream2 -> + Streams.'System.IO.Streams.withFileAsInput' \"in3.txt\" $ \\inStream3 -> + Streams.'System.IO.Streams.supply' inStream1 outStream + Streams.'System.IO.Streams.supply' inStream2 outStream + Streams.'System.IO.Streams.connect' inStream2 outStream +@ + +The final 'System.IO.Streams.connect' seals the +'System.IO.Streams.OutputStream' when the final 'System.IO.Streams.InputStream' +terminates. + +Keep in mind that you do not need to use 'System.IO.Streams.connect' or +'System.IO.Streams.supply' at all: @io-streams@ mainly provides them for user +convenience. You can always build your own abstractions on top of the +'System.IO.Streams.read' and 'System.IO.Streams.write' operations. + +-} + +{- $transform + +When we build or use 'IO' streams we can tap into all the stream-processing +features the @io-streams@ library provides. For example, we can decompress any +'System.IO.Streams.InputStream' of 'Data.ByteString.ByteString's: + +@ +import "Control.Monad" ((>=>)) +import "Data.ByteString" ('Data.ByteString.ByteString') +import "System.IO" ('System.IO.Handle') +import "System.IO.Streams" ('System.IO.Streams.InputStream', 'System.IO.Streams.OutputStream') +import qualified "System.IO.Streams" as Streams +import qualified "System.IO.Streams.File" as Streams + +unzipHandle :: 'System.IO.Handle' -> 'IO' ('System.IO.Streams.InputStream' 'Data.ByteString.ByteString') +unzipHandle = Streams.'System.IO.Streams.handleToInputStream' >=> Streams.'System.IO.Streams.decompress' +@ + +... or we can guard it against a denial-of-service attack: + +@ +protectHandle :: 'System.IO.Handle' -> 'IO' ('System.IO.Streams.InputStream' 'Data.ByteString.ByteString') +protectHandle = + Streams.'System.IO.Streams.handleToInputStream' >=> Streams.'System.IO.Streams.throwIfProducesMoreThan' 1000000 +@ + +@io-streams@ provides many useful functions such as these in its standard +library and you take advantage of them by defining IO streams that wrap your +resources. + +-} + +{- $safety + +IO streams use standard Haskell idioms for resource safety. Since all +operations occur in the IO monad, you can use 'Control.Exception.catch', +'Control.Exception.bracket', or various \"@with...@\" functions to guard any +'System.IO.Streams.read' or 'System.IO.Streams.write' without any special +considerations: + +@ +import qualified "Data.ByteString" as S +import "System.IO" +import "System.IO.Streams" ('System.IO.Streams.InputStream', 'System.IO.Streams.OutputStream') +import qualified "System.IO.Streams" as Streams +import qualified "System.IO.Streams.File" as Streams + +main = + 'System.IO.withFile' \"test.txt\" 'System.IO.ReadMode' $ \\handle -> do + stream <- Streams.'System.IO.Streams.handleToInputStream' handle + mBytes <- Streams.'System.IO.Streams.read' stream + case mBytes of + 'Just' bytes -> S.'Data.ByteString.putStrLn' bytes + 'Nothing' -> 'System.IO.putStrLn' \"EOF\" +@ + +However, you can also simplify the above example by using the convenience +function 'System.IO.Streams.File.withFileAsInput' from +"System.IO.Streams.File": + +@ +'System.IO.Streams.withFileAsInput' + :: 'System.IO.FilePath' -> ('System.IO.Streams.InputStream' 'Data.ByteString.ByteString' -> 'IO' a) -> 'IO' a +@ + +-} + +{- $pushback + +All 'System.IO.Streams.InputStream's support pushback, which simplifies many +types of operations. For example, we can 'System.IO.Streams.peek' at an +'System.IO.Streams.InputStream' by combining 'System.IO.Streams.read' and +'System.IO.Streams.unRead': + +@ +'System.IO.Streams.peek' :: 'System.IO.Streams.InputStream' c -> 'IO' ('Maybe' c) +'System.IO.Streams.peek' s = do + x <- Streams.'System.IO.Streams.read' s + case x of + 'Nothing' -> 'return' () + 'Just' c -> Streams.'System.IO.Streams.unRead' c s + 'return' x +@ + +... although "System.IO.Streams" already exports the above function. + +'System.IO.Streams.InputStream's can customize pushback behavior to support +more sophisticated support for pushback. For example, if you protect a stream +using 'System.IO.Streams.throwIfProducesMoreThan' and +'System.IO.Streams.unRead' input, it will subtract the unread input from the +total byte count. However, these extra features will not interfere with the +basic pushback contract, given by the following law: + +@ +'System.IO.Streams.unRead' c stream >> 'System.IO.Streams.read' stream == 'return' ('Just' c) +@ + +When you build an 'System.IO.Streams.InputStream' using +'System.IO.Streams.makeInputStream', it supplies the default pushback behavior +which just saves the input for the next 'System.IO.Streams.read' call. More +advanced users can use "System.IO.Streams.Internal" to customize their own +pushback routines. + +{- NOTE: The library only exports pushback API for Sources, which are a + completely internal type, so should we teach the user how to define + custom pushback or not? Maybe that belongs in some sort of separate + "advanced" tutorial for System.IO.Streams.Internal. -} +-} + +{- $threadsafety + +IO stream operations are not thread-safe by default for performance reasons. +However, you can transform an existing IO stream into a thread-safe one using +the provided locking functions: + +@ +'System.IO.Streams.lockingInputStream' :: 'System.IO.Streams.InputStream' a -> 'IO' ('System.IO.Streams.InputStream' a) +'System.IO.Streams.lockingOutputStream' :: 'System.IO.Streams.OutputStream' a -> 'IO' ('System.IO.Streams.OutputStream' a) +@ + +These functions do not prevent access to the previous IO stream, so you must +take care to not save the reference to the previous stream. + + {- NOTE: Should I give specific performance numbers or just say something + like "a slight cost to performance" for locking? -} + {- NOTE: This could use a concrete example of a race condition that a user + might encounter without this protection. -} +-} + +-- $examples +-- The following examples show how to use the standard library to implement +-- traditional command-line utilities: +-- +-- @ +--{-\# LANGUAGE OverloadedStrings #-} +-- +--import Control.Monad ((>=>), join) +--import qualified Data.ByteString.Char8 as S +--import Data.Int (Int64) +--import Data.Monoid ((\<>)) +--import "System.IO.Streams" ('System.IO.Streams.InputStream') +--import qualified "System.IO.Streams" as Streams +--import System.IO +--import Prelude hiding (head) +-- +--cat :: 'FilePath' -> IO () +--cat file = 'System.IO.withFile' file ReadMode $ \\h -> do +-- is <- Streams.'System.IO.Streams.handleToInputStream' h +-- Streams.'System.IO.Streams.connect' is Streams.'System.IO.Streams.stdout' +-- +--grep :: S.'Data.ByteString.ByteString' -> 'FilePath' -> IO () +--grep pattern file = 'System.IO.withFile' file ReadMode $ \\h -> do +-- is \<- Streams.'System.IO.Streams.handleToInputStream' h >>= +-- Streams.'System.IO.Streams.lines' >>= +-- Streams.'System.IO.Streams.filter' (S.isInfixOf pattern) +-- os <- Streams.'System.IO.Streams.unlines' Streams.'System.IO.Streams.stdout' +-- Streams.'System.IO.Streams.connect' is os +-- +--data Option = Bytes | Words | Lines +-- +--len :: 'System.IO.Streams.InputStream' a -> IO Int64 +--len = Streams.'System.IO.Streams.fold' (\\n _ -> n + 1) 0 +-- +--wc :: Option -> 'FilePath' -> IO () +--wc opt file = 'System.IO.withFile' file ReadMode $ +-- Streams.'System.IO.Streams.handleToInputStream' >=> count >=> print +-- where +-- count = case opt of +-- Bytes -> \\is -> do +-- (is', cnt) <- Streams.'System.IO.Streams.countInput' is +-- Streams.'System.IO.Streams.skipToEof' is' +-- cnt +-- Words -> Streams.'System.IO.Streams.words' >=> len +-- Lines -> Streams.'System.IO.STreams.lines' >=> len +-- +--nl :: 'FilePath' -> IO () +--nl file = 'System.IO.withFile' file ReadMode $ \\h -> do +-- nats <- Streams.'System.IO.Streams.fromList' [1..] +-- ls \<- Streams.'System.IO.Streams.handleToInputStream' h >>= Streams.'System.IO.Streams.lines' +-- is <- Streams.'System.IO.Streams.zipWith' +-- (\\n bs -> S.pack (show n) \<> \" \" \<> bs) +-- nats +-- ls +-- os <- Streams.'System.IO.Streams.unlines' Streams.'System.IO.Streams.stdout' +-- Streams.'System.IO.Streams.connect' is os +-- +--head :: Int64 -> 'FilePath' -> IO () +--head n file = 'System.IO.withFile' file ReadMode $ \\h -> do +-- is \<- Streams.'System.IO.Streams.handleToInputStream' h >>= Streams.'System.IO.Streams.lines' >>= Streams.'System.IO.Streams.take' n +-- os <- Streams.'System.IO.Streams.unlines' Streams.'System.IO.Streams.stdout' +-- Streams.'System.IO.Streams.connect' is os +-- +--paste :: 'FilePath' -> 'FilePath' -> IO () +--paste file1 file2 = +-- 'System.IO.withFile' file1 ReadMode $ \\h1 -> +-- 'System.IO.withFile' file2 ReadMode $ \\h2 -> do +-- is1 \<- Streams.'System.IO.Streams.handleToInputStream' h1 >>= Streams.'System.IO.Streams.lines' +-- is2 \<- Streams.'System.IO.Streams.handleToInputStream' h2 >>= Streams.'System.IO.Streams.lines' +-- isT \<- Streams.'System.IO.Streams.zipWith' (\\l1 l2 -> l1 \<> \"\\t\" \<> l2) is1 is2 +-- os <- Streams.'System.IO.Streams.unlines' Streams.'System.IO.Streams.stdout' +-- Streams.connect isT os +-- +--yes :: IO () +--yes = do +-- is <- Streams.fromList (repeat \"y\") +-- os <- Streams.unlines Streams.stdout +-- Streams.connect is os +-- @ diff --git a/src/System/IO/Streams/Vector.hs b/src/System/IO/Streams/Vector.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Vector.hs @@ -0,0 +1,354 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} + +-- | Vector conversions and utilities. + +module System.IO.Streams.Vector + ( -- * Vector conversions + fromVector + , toVector + , toVectorSized + , outputToVector + , outputToVectorSized + , toMutableVector + , toMutableVectorSized + , outputToMutableVector + , outputToMutableVectorSized + , writeVector + + -- * Utility + , chunkVector + , vectorOutputStream + , vectorOutputStreamSized + , mutableVectorOutputStream + , mutableVectorOutputStreamSized + ) where + +------------------------------------------------------------------------------ +import Control.Concurrent.MVar (modifyMVar, modifyMVar_, + newMVar) +import Control.Monad (liftM, (>=>)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Primitive (PrimState (..)) +import Data.IORef (IORef, newIORef, readIORef, + writeIORef) +import Data.Vector.Generic (Vector (..)) +import qualified Data.Vector.Generic as V +import Data.Vector.Generic.Mutable (MVector) +import qualified Data.Vector.Generic.Mutable as VM +import System.IO.Streams.Internal (InputStream, OutputStream, + Sink (..), fromGenerator, + nullSink, sinkToStream, yield) +import qualified System.IO.Streams.Internal as S + + +------------------------------------------------------------------------------ +-- | Transforms a vector into an 'InputStream' that yields each of the values +-- in the vector in turn. +-- +-- @ +-- ghci> import "Control.Monad" +-- ghci> import qualified "System.IO.Streams" as Streams +-- ghci> import qualified "Data.Vector" as V +-- ghci> let v = V.'Data.Vector.fromList' [1, 2] +-- ghci> is <- Streams.'fromVector' v +-- ghci> 'Control.Monad.replicateM' 3 (Streams.'read' is) +-- ['Just' 1,'Just' 2,'Nothing'] +-- @ +fromVector :: Vector v a => v a -> IO (InputStream a) +fromVector = fromGenerator . V.mapM_ yield +{-# INLINE fromVector #-} + + +------------------------------------------------------------------------------ +-- | Drains an 'InputStream', converting it to a vector. Note that this +-- function reads the entire 'InputStream' strictly into memory and as such is +-- not recommended for streaming applications or where the size of the input is +-- not bounded or known. +-- +-- @ +-- ghci> is <- Streams.'System.IO.Streams.fromList' [(1::Int)..4] +-- ghci> Streams.'toVector' is :: 'IO' (V.'Vector' Int) +-- fromList [1,2,3,4] +-- @ +toVector :: Vector v a => InputStream a -> IO (v a) +toVector = toVectorSized dEFAULT_BUFSIZ +{-# INLINE toVector #-} + + +------------------------------------------------------------------------------ +-- | Like 'toVector', but allows control over how large the vector buffer is to +-- start with. +toVectorSized :: Vector v a => Int -> InputStream a -> IO (v a) +toVectorSized n = toMutableVectorSized n >=> V.basicUnsafeFreeze +{-# INLINE toVectorSized #-} + + +------------------------------------------------------------------------------ +-- | Drains an 'InputStream', converting it to a mutable vector. Note that this +-- function reads the entire 'InputStream' strictly into memory and as such is +-- not recommended for streaming applications or where the size of the input is +-- not bounded or known. +toMutableVector :: VM.MVector v a => InputStream a -> IO (v (PrimState IO) a) +toMutableVector = toMutableVectorSized dEFAULT_BUFSIZ + + +------------------------------------------------------------------------------ +-- | Like 'toMutableVector', but allows control over how large the vector +-- buffer is to start with. +toMutableVectorSized :: VM.MVector v a => + Int -- ^ initial size of the vector buffer + -> InputStream a + -> IO (v (PrimState IO) a) +toMutableVectorSized initialSize input = vfNew initialSize >>= go + where + go vfi = S.read input >>= maybe (vfFinish vfi) (vfAppend vfi >=> go) +{-# INLINE toMutableVectorSized #-} + + +------------------------------------------------------------------------------ +-- | 'vectorOutputStream' returns an 'OutputStream' which stores values fed +-- into it and an action which flushes all stored values to a vector. +-- +-- The flush action resets the store. +-- +-- Note that this function /will/ buffer any input sent to it on the heap. +-- Please don't use this unless you're sure that the amount of input provided +-- is bounded and will fit in memory without issues. +-- +-- @ +-- ghci> (os, flush) <- Streams.'vectorOutputStream' :: IO ('OutputStream' Int, IO (V.'Vector' Int)) +-- ghci> Streams.'System.IO.Streams.write' (Just 1) os +-- ghci> Streams.'System.IO.Streams.write' (Just 2) os +-- ghci> flush +-- fromList [1,2] +-- ghci> Streams.'System.IO.Streams.write' (Just 3) os +-- ghci> Streams.'System.IO.Streams.write' Nothing os +-- ghci> Streams.'System.IO.Streams.write' (Just 4) os +-- ghci> flush +-- fromList [3] +-- @ +vectorOutputStream :: Vector v c => IO (OutputStream c, IO (v c)) +vectorOutputStream = vectorOutputStreamSized dEFAULT_BUFSIZ +{-# INLINE vectorOutputStream #-} + + +------------------------------------------------------------------------------ +-- | Like 'vectorOutputStream', but allows control over how large the vector +-- buffer is to start with. +vectorOutputStreamSized :: Vector v c => Int -> IO (OutputStream c, IO (v c)) +vectorOutputStreamSized n = do + (os, flush) <- mutableVectorOutputStreamSized n + return $! (os, flush >>= V.basicUnsafeFreeze) + + +------------------------------------------------------------------------------ +data VectorFillInfo v c = VectorFillInfo { + _vec :: !(v (PrimState IO) c) + , _idx :: {-# UNPACK #-} !(IORef Int) + + -- TODO: vector contains its own size + , _sz :: {-# UNPACK #-} !(IORef Int) + } + + +------------------------------------------------------------------------------ +vfNew :: MVector v a => Int -> IO (VectorFillInfo v a) +vfNew initialSize = do + v <- VM.unsafeNew initialSize + i <- newIORef 0 + sz <- newIORef initialSize + return $! VectorFillInfo v i sz + + +------------------------------------------------------------------------------ +vfFinish :: MVector v a => + VectorFillInfo v a + -> IO (v (PrimState IO) a) +vfFinish vfi = liftM (flip VM.unsafeTake v) $ readIORef i + where + v = _vec vfi + i = _idx vfi + + +------------------------------------------------------------------------------ +vfAppend :: MVector v a => + VectorFillInfo v a + -> a + -> IO (VectorFillInfo v a) +vfAppend vfi !x = do + i <- readIORef iRef + sz <- readIORef szRef + if i < sz then add i else grow sz + where + v = _vec vfi + iRef = _idx vfi + szRef = _sz vfi + + add i = do + VM.unsafeWrite v i x + writeIORef iRef $! i + 1 + return vfi + + grow sz = do + let !sz' = sz * 2 + v' <- VM.unsafeGrow v sz + writeIORef szRef sz' + vfAppend (vfi { _vec = v' }) x + + +------------------------------------------------------------------------------ +-- | 'mutableVectorOutputStream' returns an 'OutputStream' which stores values +-- fed into it and an action which flushes all stored values to a vector. +-- +-- The flush action resets the store. +-- +-- Note that this function /will/ buffer any input sent to it on the heap. +-- Please don't use this unless you're sure that the amount of input provided +-- is bounded and will fit in memory without issues. +mutableVectorOutputStream :: VM.MVector v c => + IO (OutputStream c, IO (v (PrimState IO) c)) +mutableVectorOutputStream = mutableVectorOutputStreamSized dEFAULT_BUFSIZ + + +------------------------------------------------------------------------------ +-- | Like 'mutableVectorOutputStream', but allows control over how large the +-- vector buffer is to start with. +mutableVectorOutputStreamSized :: VM.MVector v c => + Int + -> IO (OutputStream c, IO (v (PrimState IO) c)) +mutableVectorOutputStreamSized initialSize = do + r <- vfNew initialSize >>= newMVar + c <- sinkToStream $ consumer r + return (c, flush r) + + where + consumer r = go + where + go = Sink $ maybe (return nullSink) + (\c -> do + modifyMVar_ r $ flip vfAppend c + return go) + flush r = modifyMVar r $ \vfi -> do + !v <- vfFinish vfi + vfi' <- vfNew initialSize + return $! (vfi', v) +{-# INLINE mutableVectorOutputStream #-} + + +------------------------------------------------------------------------------ +-- | Given an IO action that requires an 'OutputStream', creates one and +-- captures all the output the action sends to it as a mutable vector. +-- +-- Example: +-- +-- @ +-- ghci> import "Control.Applicative" +-- ghci> ('connect' \<\$\> 'System.IO.Streams.fromList' [1, 2, 3::'Int']) +-- \>\>= 'outputToMutableVector' +-- \>\>= V.'Data.Vector.freeze' +-- fromList [1,2,3] +-- @ +outputToMutableVector :: MVector v a => + (OutputStream a -> IO b) + -> IO (v (PrimState IO) a) +outputToMutableVector = outputToMutableVectorSized dEFAULT_BUFSIZ +{-# INLINE outputToMutableVector #-} + + +------------------------------------------------------------------------------ +-- | Like 'outputToMutableVector', but allows control over how large the vector +-- buffer is to start with. +outputToMutableVectorSized :: MVector v a => + Int + -> (OutputStream a -> IO b) + -> IO (v (PrimState IO) a) +outputToMutableVectorSized n f = do + (os, getVec) <- mutableVectorOutputStreamSized n + _ <- f os + getVec +{-# INLINE outputToMutableVectorSized #-} + + +------------------------------------------------------------------------------ +-- | Given an IO action that requires an 'OutputStream', creates one and +-- captures all the output the action sends to it as a vector. +-- +-- Example: +-- +-- @ +-- ghci> (('connect' <$> 'System.IO.Streams.fromList' [1, 2, 3]) >>= 'outputToVector') +-- :: IO ('Data.Vector.Vector' Int) +-- fromList [1,2,3] +-- @ +outputToVector :: Vector v a => (OutputStream a -> IO b) -> IO (v a) +outputToVector = outputToVectorSized dEFAULT_BUFSIZ +{-# INLINE outputToVector #-} + + +------------------------------------------------------------------------------ +-- | Like 'outputToVector', but allows control over how large the vector buffer +-- is to start with. +outputToVectorSized :: Vector v a => + Int + -> (OutputStream a -> IO b) + -> IO (v a) +outputToVectorSized n = outputToMutableVectorSized n >=> V.basicUnsafeFreeze +{-# INLINE outputToVectorSized #-} + + +------------------------------------------------------------------------------ +-- | Splits an input stream into chunks of at most size @n@. +-- +-- Example: +-- +-- @ +-- ghci> ('System.IO.Streams.fromList' [1..14::Int] >>= 'chunkVector' 4 >>= 'System.IO.Streams.toList') +-- :: IO ['Data.Vector.Vector' Int] +-- [fromList [1,2,3,4],fromList [5,6,7,8],fromList [9,10,11,12],fromList [13,14]] +-- @ +chunkVector :: Vector v a => Int -> InputStream a -> IO (InputStream (v a)) +chunkVector n input = if n <= 0 + then error $ "chunkVector: bad size: " ++ show n + else vfNew n >>= fromGenerator . go n + where + doneChunk !vfi = do + liftIO (vfFinish vfi >>= V.unsafeFreeze) >>= yield + !vfi' <- liftIO $ vfNew n + go n vfi' + + go !k !vfi | k <= 0 = doneChunk vfi + | otherwise = liftIO (S.read input) >>= maybe finish chunk + where + finish = do + v <- liftIO (vfFinish vfi >>= V.unsafeFreeze) + if V.null v then return $! () else yield v + + chunk x = do + !vfi' <- liftIO $ vfAppend vfi x + go (k - 1) vfi' +{-# INLINE chunkVector #-} + + +------------------------------------------------------------------------------ +-- | Feeds a vector to an 'OutputStream'. Does /not/ write an end-of-stream to +-- the stream. +-- +-- @ +-- ghci> let v = V.'fromList' [1..4] :: V.'Vector' Int +-- ghci> os \<- Streams.'unlines' Streams.'stdout' >>= Streams.'System.IO.Streams.contramap' (S.pack . show) :: IO ('OutputStream' Int) +-- ghci> Streams.'writeVector' v os +-- 1 +-- 2 +-- 3 +-- 4 +-- @ +writeVector :: Vector v a => v a -> OutputStream a -> IO () +writeVector v out = V.mapM_ (flip S.write out . Just) v +{-# INLINE writeVector #-} + + +------------------------------------------------------------------------------ +dEFAULT_BUFSIZ :: Int +dEFAULT_BUFSIZ = 64 diff --git a/src/System/IO/Streams/Zlib.hs b/src/System/IO/Streams/Zlib.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Zlib.hs @@ -0,0 +1,213 @@ +-- | Interface to @zlib@ and @gzip@ compression for 'Bytestring's and 'Builder's + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module System.IO.Streams.Zlib + ( -- * ByteString decompression + gunzip + , decompress + -- * ByteString compression + , gzip + , compress + -- * Builder compression + , gzipBuilder + , compressBuilder + -- * Compression level + , CompressionLevel(..) + , defaultCompressionLevel + ) where + +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder (fromByteString) +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder.Internal (Builder, + defaultBufferSize, + flush) +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder.Internal.Buffer (allocBuffer) +------------------------------------------------------------------------------ +import Codec.Zlib (Deflate, Inflate, + Popper, + WindowBits (..), + feedDeflate, + feedInflate, + finishDeflate, + finishInflate, + flushDeflate, + flushInflate, + initDeflate, + initInflate) +------------------------------------------------------------------------------ +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import Data.IORef (newIORef, readIORef, + writeIORef) +import Prelude hiding (read) +------------------------------------------------------------------------------ +import System.IO.Streams.Builder (unsafeBuilderStream) +import System.IO.Streams.Internal (InputStream, + OutputStream, + makeInputStream, + makeOutputStream, + read, write) + + +------------------------------------------------------------------------------ +gzipBits :: WindowBits +gzipBits = WindowBits 31 + + +------------------------------------------------------------------------------ +compressBits :: WindowBits +compressBits = WindowBits 15 + + +------------------------------------------------------------------------------ +-- | Decompress an 'InputStream' of strict 'ByteString's from the @gzip@ format +gunzip :: InputStream ByteString -> IO (InputStream ByteString) +gunzip input = initInflate gzipBits >>= inflate input + + +------------------------------------------------------------------------------ +-- | Decompress an 'InputStream' of strict 'ByteString's from the @zlib@ format +decompress :: InputStream ByteString -> IO (InputStream ByteString) +decompress input = initInflate compressBits >>= inflate input + + +------------------------------------------------------------------------------ +-- Note: bytes pushed back to this input stream are not propagated back to the +-- source InputStream. +data IS = Input + | Popper Popper + | Done + +inflate :: InputStream ByteString -> Inflate -> IO (InputStream ByteString) +inflate input state = do + ref <- newIORef Input + makeInputStream $ stream ref + + where + stream ref = go + where + go = readIORef ref >>= \st -> + case st of + Input -> read input >>= maybe eof chunk + Popper p -> pop p + Done -> return Nothing + + eof = do + x <- finishInflate state + writeIORef ref Done + if (not $ S.null x) + then return $! Just x + else return Nothing + + chunk s = + if S.null s + then do + out <- flushInflate state + return $! Just out + else feedInflate state s >>= \popper -> do + writeIORef ref $ Popper popper + pop popper + + pop popper = popper >>= maybe backToInput (return . Just) + backToInput = writeIORef ref Input >> read input >>= maybe eof chunk + + +------------------------------------------------------------------------------ +deflateBuilder :: OutputStream Builder + -> Deflate + -> IO (OutputStream Builder) +deflateBuilder stream state = do + zippedStr <- makeOutputStream bytestringStream >>= + \x -> deflate x state + + -- we can use unsafeBuilderStream here because zlib is going to consume the + -- stream + unsafeBuilderStream (allocBuffer defaultBufferSize) zippedStr + + where + bytestringStream x = write (fmap cvt x) stream + + cvt s | S.null s = flush + | otherwise = fromByteString s + + +------------------------------------------------------------------------------ +-- | Convert an 'OutputStream' that consumes compressed 'Builder's into an +-- 'OutputStream' that consumes uncompressed 'Builder's in the @gzip@ format +gzipBuilder :: CompressionLevel + -> OutputStream Builder + -> IO (OutputStream Builder) +gzipBuilder level output = + initDeflate (clamp level) gzipBits >>= deflateBuilder output + + +------------------------------------------------------------------------------ +-- | Convert an 'OutputStream' that consumes compressed 'Builder's into an +-- 'OutputStream' that consumes uncompressed 'Builder's in the @zlib@ format +compressBuilder :: CompressionLevel + -> OutputStream Builder + -> IO (OutputStream Builder) +compressBuilder level output = + initDeflate (clamp level) compressBits >>= deflateBuilder output + + +------------------------------------------------------------------------------ +deflate :: OutputStream ByteString + -> Deflate + -> IO (OutputStream ByteString) +deflate output state = makeOutputStream stream + where + stream Nothing = popAll (finishDeflate state) >> write Nothing output + + stream (Just s) = do + -- Empty string means flush + if S.null s + then do + popAll (flushDeflate state) + write (Just S.empty) output + + else feedDeflate state s >>= popAll + + + popAll popper = go + where + go = popper >>= maybe (return $! ()) (\s -> write (Just s) output >> go) + + +------------------------------------------------------------------------------ +-- | Parameter that defines the tradeoff between speed and compression ratio +newtype CompressionLevel = CompressionLevel Int + deriving (Read, Eq, Show, Num) + + +------------------------------------------------------------------------------ +-- | A compression level that balances speed with compression ratio +defaultCompressionLevel :: CompressionLevel +defaultCompressionLevel = CompressionLevel 5 + + +------------------------------------------------------------------------------ +clamp :: CompressionLevel -> Int +clamp (CompressionLevel x) = min 9 (max x 0) + + +------------------------------------------------------------------------------ +-- | Convert an 'OutputStream' that consumes compressed 'ByteString's into an +-- 'OutputStream' that consumes uncompressed 'ByteString's in the @gzip@ format +gzip :: CompressionLevel + -> OutputStream ByteString + -> IO (OutputStream ByteString) +gzip level output = initDeflate (clamp level) gzipBits >>= deflate output + + +------------------------------------------------------------------------------ +-- | Convert an 'OutputStream' that consumes compressed 'ByteString's into an +-- 'OutputStream' that consumes uncompressed 'ByteString's in the @zlib@ format +compress :: CompressionLevel + -> OutputStream ByteString + -> IO (OutputStream ByteString) +compress level output = initDeflate (clamp level) compressBits >>= + deflate output diff --git a/test/System/IO/Streams/Tests/Attoparsec.hs b/test/System/IO/Streams/Tests/Attoparsec.hs new file mode 100644 --- /dev/null +++ b/test/System/IO/Streams/Tests/Attoparsec.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.IO.Streams.Tests.Attoparsec (tests) where + +------------------------------------------------------------------------------ +import Control.Monad +import Data.Attoparsec.ByteString.Char8 +import Data.ByteString.Char8 (ByteString) +import Prelude hiding (takeWhile) +import System.IO.Streams +import System.IO.Streams.Internal.Attoparsec +import System.IO.Streams.Tests.Common +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +------------------------------------------------------------------------------ + +tests :: [Test] +tests = [ testParseFromStream + , testParseFromStreamError + , testParseFromStreamError2 + , testPartialParse + , testEmbeddedNull + , testTrivials + ] + + +------------------------------------------------------------------------------ +testParser :: Parser (Maybe Int) +testParser = do + end <- atEnd + if end + then return Nothing + else do + _ <- takeWhile (\c -> isSpace c || c == ',') + liftM Just decimal + + +------------------------------------------------------------------------------ +testParser2 :: Parser (Maybe ByteString) +testParser2 = do + end <- atEnd + if end + then return Nothing + else liftM Just $ string "bork" + + +------------------------------------------------------------------------------ +testParseFromStream :: Test +testParseFromStream = testCase "attoparsec/parseFromStream" $ do + is <- fromList ["1", "23", ", 4", ", 5, 6, 7"] + x0 <- parseFromStream testParser is + + assertEqual "first parse" (Just 123) x0 + + l <- parserToInputStream testParser is >>= toList + + assertEqual "rest" [4, 5, 6, 7] l + toList is >>= assertEqual "double eof" [] + + +------------------------------------------------------------------------------ +testParseFromStreamError :: Test +testParseFromStreamError = testCase "attoparsec/parseFromStreamError" $ do + is <- fromList ["1", "23", ", 4", ",xxxx 5, 6, 7"] >>= + parserToInputStream testParser + + expectExceptionH $ toList is + + +------------------------------------------------------------------------------ +testParseFromStreamError2 :: Test +testParseFromStreamError2 = testCase "attoparsec/parseFromStreamError2" $ do + l <- fromList ["borkbork", "bork"] >>= p + assertEqual "ok" ["bork", "bork", "bork"] l + + expectExceptionH $ fromList ["bork", "bo"] >>= p + expectExceptionH $ fromList ["xxxxx"] >>= p + + where + p = parserToInputStream testParser2 >=> toList + + +------------------------------------------------------------------------------ +testPartialParse :: Test +testPartialParse = testCase "attoparsec/partialParse" $ do + is <- fromList ["1,", "2,", "3"] + expectExceptionH $ parseFromStreamInternal parseFunc feedFunc testParser is + + where + result = Partial (const result) + parseFunc = const $ const $ result + feedFunc = const $ const $ result + +------------------------------------------------------------------------------ +testTrivials :: Test +testTrivials = testCase "attoparsec/trivials" $ do + coverTypeableInstance (undefined :: ParseException) + + +------------------------------------------------------------------------------ +testEmbeddedNull :: Test +testEmbeddedNull = testCase "attoparsec/embeddedNull" $ do + is <- fromList ["", "1", "23", "", ", 4", ", 5, 6, 7"] + x0 <- parseFromStream testParser is + + assertEqual "first parse" (Just 123) x0 + + l <- parserToInputStream testParser is >>= toList + + assertEqual "rest" [4, 5, 6, 7] l diff --git a/test/System/IO/Streams/Tests/Builder.hs b/test/System/IO/Streams/Tests/Builder.hs new file mode 100644 --- /dev/null +++ b/test/System/IO/Streams/Tests/Builder.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.IO.Streams.Tests.Builder (tests) where + +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Internal.Buffer +import Control.Monad +import qualified Data.ByteString.Char8 as S +import Data.List +import Data.Monoid +import System.IO.Streams hiding + (fromByteString, + intersperse, map, + take) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +------------------------------------------------------------------------------ + +tests :: [Test] +tests = [ testBuilderStream + , testUnsafeBuilderStream + , testSmallBuffer + , testSmallBufferWithLargeOutput + , testNullStream + ] + + +------------------------------------------------------------------------------ +testBuilderStream :: Test +testBuilderStream = testCase "builder/builderStream" $ do + let l1 = intersperse " " ["the", "quick", "brown", "fox"] + let l2 = intersperse " " ["jumped", "over", "the"] + let l = map fromByteString l1 ++ [flush] ++ map fromByteString l2 + + is <- fromList l + (os0, grab) <- listOutputStream + os <- builderStream os0 + + connect is os + output <- grab + assertEqual "properly buffered" + [ "the quick brown fox" + , "" + , "jumped over the" + ] + output + + +------------------------------------------------------------------------------ +testUnsafeBuilderStream :: Test +testUnsafeBuilderStream = testCase "builder/unsafeBuilderStream" $ do + let l1 = intersperse " " ["the", "quick", "brown", "fox"] + let l2 = intersperse " " ["jumped", "over", "the"] + let l = map fromByteString l1 ++ [flush] ++ map fromByteString l2 + + is <- fromList l + (os0, grab) <- listOutputStream + os1 <- contramapM (return . S.copy) os0 + + os <- unsafeBuilderStream (allocBuffer 1024) os1 + + connect is os + output <- grab + assertEqual "properly buffered" + [ "the quick brown fox" + , "" + , "jumped over the" + ] + output + +------------------------------------------------------------------------------ +testSmallBuffer :: Test +testSmallBuffer = testCase "builder/smallBuffer" $ do + (os0, grab) <- listOutputStream + os <- builderStreamWith (allNewBuffersStrategy 10) os0 + let l1 = intersperse " " ["the", "quick", "brown"] + let l2 = [" fooooooooooooooooox"] + let l = map fromByteString l1 ++ [flush, flush, flush] + ++ map fromByteString l2 + + is <- fromList l + connect is os + output <- liftM S.concat grab + + assertEqual "short buffer" "the quick brown fooooooooooooooooox" output + + +------------------------------------------------------------------------------ +testSmallBufferWithLargeOutput :: Test +testSmallBufferWithLargeOutput = + testCase "builder/smallBufferWithLargeOutput" $ do + (os0, grab) <- listOutputStream + os1 <- contramapM (return . S.copy) os0 + os <- unsafeBuilderStream (allocBuffer 10) os1 + + let l = take 3000 $ cycle $ + replicate 20 (fromByteString "bloooooooort") ++ [flush] + + is <- fromList l + let s = toByteString $ mconcat l + + connect is os + output <- liftM S.concat grab + + assertEqual "short buffer 2" s output + + write (Just $ fromByteString "ok") os + write Nothing os + + fout <- grab + + -- no output should be sent because of nullSink + assertEqual "nullSink" [] fout + + +------------------------------------------------------------------------------ +testNullStream :: Test +testNullStream = testCase "builder/nullStream" $ do + (os0, grab) <- listOutputStream + os <- builderStream os0 + + is <- fromList [] + connect is os + + l <- grab + assertEqual "null stream" [] l diff --git a/test/System/IO/Streams/Tests/ByteString.hs b/test/System/IO/Streams/Tests/ByteString.hs new file mode 100644 --- /dev/null +++ b/test/System/IO/Streams/Tests/ByteString.hs @@ -0,0 +1,611 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.IO.Streams.Tests.ByteString (tests) where + +------------------------------------------------------------------------------ +import Control.Concurrent +import Control.Monad +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Data.List hiding (lines, + takeWhile, unlines, + unwords, words) +import Data.Monoid +import Prelude hiding (lines, read, + takeWhile, unlines, + unwords, unwords, + words) +import qualified Prelude +import System.IO.Streams hiding (filter, + intersperse, mapM_) +import System.IO.Streams.Tests.Common +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit hiding (Test) +import Test.QuickCheck hiding (output) +import Test.QuickCheck.Monadic +------------------------------------------------------------------------------ + +tests :: [Test] +tests = [ testBoyerMoore + , testBoyerMoore2 + , testCountInput + , testCountInput2 + , testCountOutput + , testThrowIfTooSlow + , testReadExactly + , testTakeWhile + , testTakeBytes + , testTakeBytes2 + , testTakeBytes3 + , testThrowIfProducesMoreThan + , testThrowIfProducesMoreThan2 + , testThrowIfProducesMoreThan3 + , testThrowIfConsumesMoreThan + , testThrowIfConsumesMoreThan2 + , testTrivials + , testWriteLazyByteString + , testGiveBytes + , testGiveExactly + , testLines + , testWords + ] + + +------------------------------------------------------------------------------ +testCountInput :: Test +testCountInput = testProperty "bytestring/countInput" $ + monadicIO $ + forAllM arbitrary prop + where + prop :: [ByteString] -> PropertyM IO () + prop l = liftQ $ do + is <- fromList l + (is', grab) <- countInput is + + x <- toList is' + n <- grab + + assertEqual "countInput1" (L.length $ L.fromChunks l) n + assertEqual "countInput2" (L.length $ L.fromChunks x) n + + read is' >>= assertEqual "eof" Nothing + unRead "ok" is' + peek is >>= assertEqual "peek" (Just "ok") + read is' >>= assertEqual "read" (Just "ok") + + +------------------------------------------------------------------------------ +testCountInput2 :: Test +testCountInput2 = testCase "bytestring/countInput2" $ do + is <- fromList txt + (is', getCount) <- countInput is + (Just x) <- read is' + + unRead "0, " is' + getCount >>= assertEqual "count1" 5 + peek is >>= assertEqual "pushback propagates" (Just "0, ") + + (liftM (L.fromChunks . (x:)) $ toList is') >>= + assertEqual "output" expectedOutput + + getCount >>= assertEqual "count2" (L.length $ L.fromChunks txt) + + where + txt = ["testing ", "1, ", "2, ", "3"] + expectedOutput = "testing 0, 1, 2, 3" + + +------------------------------------------------------------------------------ +testCountOutput :: Test +testCountOutput = testProperty "bytestring/countOutput" $ + monadicIO $ + forAllM arbitrary prop + where + prop :: [ByteString] -> PropertyM IO () + prop l = liftQ $ do + is <- fromList l + (os0, grab) <- listOutputStream + (os, grabLen) <- countOutput os0 + + connect is os + + xs <- grab + n <- grabLen + + assertEqual "countOutput1" l xs + assertEqual "countOutput2" (L.length $ L.fromChunks l) n + + +------------------------------------------------------------------------------ +testTakeBytes :: Test +testTakeBytes = testProperty "bytestring/takeBytes" $ + monadicIO $ + forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop l = pre (L.length l > 5) >> liftQ (do + let (a,b) = L.splitAt 4 l + + is <- fromList (L.toChunks l) + is' <- takeBytes 4 is + + x <- liftM L.fromChunks $ toList is' + y <- liftM L.fromChunks $ toList is + + assertEqual "take1" a x + assertEqual "take2" b y + ) + + +------------------------------------------------------------------------------ +testTakeBytes2 :: Test +testTakeBytes2 = testProperty "bytestring/takeBytes2" $ + monadicIO $ + forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop l = liftQ $ do + is <- fromList (L.toChunks l) + is2 <- takeBytes 0 is + + x <- toList is2 + y <- liftM L.fromChunks $ toList is + + assertEqual "takeBytes3" [] x + assertEqual "takeBytes4" l y + + -- Test that pushback makes it back to the source inputstream + is3 <- takeBytes 20 is + void $ toList is3 + unRead "ok2" is3 + unRead "ok1" is3 + + z <- toList is + assertEqual "takeBytes5" ["ok1", "ok2"] z + + +------------------------------------------------------------------------------ +testTakeBytes3 :: Test +testTakeBytes3 = testCase "bytestring/takeBytes3" $ do + is <- fromLazyByteString (L.fromChunks ["The", "quick", "brown", "fox"]) >>= + takeBytes 100 + _ <- toList is + m <- read is + + assertEqual "takeBytes3" Nothing m + + +------------------------------------------------------------------------------ +testThrowIfProducesMoreThan :: Test +testThrowIfProducesMoreThan = + testProperty "bytestring/throwIfProducesMoreThan" $ + monadicIO $ forAllM arbitrary prop + + where + prop :: L.ByteString -> PropertyM IO () + prop l = do + pre (L.length l > 5) + + liftQ $ do + is <- fromList $ L.toChunks l + is' <- throwIfProducesMoreThan 4 is + expectExceptionH $ toList is' + + +------------------------------------------------------------------------------ +testThrowIfProducesMoreThan2 :: Test +testThrowIfProducesMoreThan2 = + testProperty "bytestring/throwIfProducesMoreThan2" $ + monadicIO $ forAllM arbitrary prop + + where + prop :: L.ByteString -> PropertyM IO () + prop l = do + let n = L.length l + + liftQ $ do + is <- fromList $ L.toChunks l + is' <- throwIfProducesMoreThan (n + 1) is + l' <- liftM L.fromChunks $ toList is' + assertEqual "throwIfProducesMoreThan2" l l' + + m <- read is' + assertEqual "throwIfProducesMoreThan2-2" Nothing m + + unRead "ok2" is' + unRead "ok1" is' + z <- toList is + assertEqual "throwIfProducesMoreThan2-3" ["ok1", "ok2"] z + + +------------------------------------------------------------------------------ +testThrowIfProducesMoreThan3 :: Test +testThrowIfProducesMoreThan3 = + testCase "bytestring/throwIfProducesMoreThan3" $ do + is <- fromList ["lo", "ngstring"] >>= throwIfProducesMoreThan 4 + s <- readExactly 4 is + assertEqual "throwIfProducesMoreThan split" "long" s + + l <- fromList ["ok", "", "", "", ""] >>= throwIfProducesMoreThan 2 >>= + toList + assertEqual "throwIfProducesMoreThan3" ["ok", "", "", "", ""] l + + +------------------------------------------------------------------------------ +testThrowIfConsumesMoreThan :: Test +testThrowIfConsumesMoreThan = + testProperty "bytestring/throwIfConsumesMoreThan" $ + monadicIO $ + forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop l = do + let n = L.length l + pre (n > 0) + liftQ $ do + is <- fromList (L.toChunks l) + (os, _) <- listOutputStream + os' <- throwIfConsumesMoreThan (n-1) os + + expectExceptionH $ connect is os' + + +------------------------------------------------------------------------------ +testThrowIfConsumesMoreThan2 :: Test +testThrowIfConsumesMoreThan2 = + testProperty "bytestring/throwIfConsumesMoreThan2" $ + monadicIO $ + forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop l = do + let n = L.length l + + liftQ $ do + is <- fromList (L.toChunks l) + (os, grab) <- listOutputStream + os' <- throwIfConsumesMoreThan n os + + connect is os' + + l' <- liftM L.fromChunks grab + assertEqual "throwIfConsumesMoreThan" l l' + + -- cover nullSink behaviour + write (Just "blah") os' + nil <- liftM L.fromChunks grab + assertEqual "nil after eof" "" nil + + +------------------------------------------------------------------------------ +testGiveExactly :: Test +testGiveExactly = testCase "bytestring/giveExactly" $ do + f 2 >>= assertEqual "ok" ["ok"] + expectExceptionH $ f 1 + expectExceptionH $ f 3 + + where + f n = do + is <- fromByteString "ok" + outputToList (giveExactly n >=> connect is) + + +------------------------------------------------------------------------------ +testGiveBytes :: Test +testGiveBytes = testProperty "bytestring/giveBytes" $ + monadicIO $ + forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop l = do + pre (L.length l > 5) + let a = L.take 4 l + + liftQ $ do + is <- fromList (L.toChunks l) + (os, grab) <- listOutputStream + os' <- giveBytes 4 os + + connect is os' + write Nothing os' + + x <- liftM L.fromChunks grab + + assertEqual "giveBytes1" a x + + liftQ $ do + is <- fromList $ L.toChunks a + (os, grab) <- listOutputStream + os' <- giveBytes 10 os + + connect is os' + write Nothing os' + x <- liftM L.fromChunks grab + assertEqual "giveBytes2" a x + + +------------------------------------------------------------------------------ +testThrowIfTooSlow :: Test +testThrowIfTooSlow = testCase "bytestring/throwIfTooSlow" $ do + is <- mkList + expectExceptionH $ trickleFrom is + + is' <- mkList + void $ toList is' + x <- read is' + + assertEqual "throwIfTooSlow" Nothing x + + src <- mkSrc + src' <- throwIfTooSlow (return ()) 10 2 src + + void $ toList src' + unRead "ok2" src' + unRead "ok1" src' + l <- toList src + + assertEqual "throwIfTooSlow/pushback" ["ok1", "ok2"] l + + + where + mkSrc = fromList $ Prelude.take 100 $ cycle $ + intersperse " " ["the", "quick", "brown", "fox"] + + mkList = mkSrc >>= throwIfTooSlow (return ()) 10 2 + + trickleFrom is = go + where + go = read is >>= maybe (return ()) + (\x -> x `seq` (threadDelay 2000000 >> go)) + + +------------------------------------------------------------------------------ +testBoyerMoore :: Test +testBoyerMoore = testProperty "bytestring/boyerMoore" $ + monadicIO $ forAllM gen prop + where + genBS range = liftM S.pack $ listOf $ choose range + + gen :: Gen (ByteString, [ByteString]) + gen = do + needle <- genBS ('a', 'z') + n <- choose (0, 10) + hay <- replicateM n $ genBS ('A', 'Z') + return (needle, hay) + + prop :: (ByteString, [ByteString]) -> PropertyM IO () + prop (needle, haystack') = do + let lneedle = L.fromChunks [needle] + let lhaystack = L.fromChunks haystack' + + pre ((not $ S.null needle) && + (not $ L.null lhaystack) && + (not $ S.isInfixOf needle $ S.concat haystack')) + + + (lhay, toklist0) <- insertNeedle lneedle lhaystack + let stream = L.toChunks $ L.concat [lneedle, lhay] + let toklist = (Match needle) : toklist0 + + -- there should be exactly three matches + out <- liftQ (fromList stream >>= search needle >>= toList) + + let nMatches = length $ filter isMatch out + + let out' = concatAdj Nothing id out + + when (nMatches /= 3 || out' /= toklist) $ liftQ $ do + putStrLn "got wrong output!!" + putStrLn "needle:\n" + putStrLn $ show lneedle + putStrLn "\nhaystack:\n" + mapM_ (putStrLn . show) stream + putStrLn "\noutput stream:" + mapM_ (putStrLn . show) out + putStrLn "\noutput stream (minified):" + mapM_ (putStrLn . show) out' + putStrLn "\nexpected output:" + mapM_ (putStrLn . show) toklist + putStrLn "" + + liftQ $ do + assertEqual "boyer-moore matches" 3 nMatches + assertEqual "boyer-moore output" toklist out' + + + isMatch (Match _) = True + isMatch _ = False + + concatAdj :: Maybe MatchInfo + -> ([MatchInfo] -> [MatchInfo]) + -> [MatchInfo] + -> [MatchInfo] + concatAdj prefix dl [] = dl $ maybe [] (:[]) prefix + concatAdj prefix dl (x:xs) = + maybe (concatAdj (Just x) dl xs) + (\p -> maybe (concatAdj (Just x) (dl . (p:)) xs) + (\x' -> concatAdj (Just x') dl xs) + (merge p x)) + prefix + + where + merge (NoMatch z) y + | S.null z = Just y + | otherwise = case y of + NoMatch x' -> Just $ NoMatch $ z `mappend` x' + _ -> Nothing + + merge (Match _) _ = Nothing + + insertNeedle lneedle lhaystack = do + idxL <- pick $ choose (0, lenL-1) + idxN <- pick $ choose (0, lenN-1) + idxN2 <- pick $ choose (0, lenN-1) + let (l1, l2) = L.splitAt (toEnum idxL) lhaystack + let (n1, n2) = L.splitAt (toEnum idxN) lneedle + let (n3, n4) = L.splitAt (toEnum idxN2) lneedle + + let out1 = L.concat [ l1, n1, n2, l2, n3, n4 ] + + let res = concatAdj Nothing id + [ NoMatch $ strict l1 + , Match $ strict lneedle + , NoMatch $ strict l2 + , Match $ strict lneedle + ] + + return (out1, res) + + where + strict = S.concat . L.toChunks + + lenN = fromEnum $ L.length lneedle + lenL = fromEnum $ L.length lhaystack + + +------------------------------------------------------------------------------ +testBoyerMoore2 :: Test +testBoyerMoore2 = testCase "bytestring/boyerMoore2" $ do + fromList ["bork", "no", "bork", "bor"] + >>= search "bork" + >>= toList + >>= assertEqual "bork!" [ Match "bork", NoMatch "no", Match "bork" + , NoMatch "bor" ] + + fromList [] >>= search "bork" >>= toList >>= assertEqual "nothing" [] + + fromList ["borkbo", "r"] >>= search "bork" >>= toList + >>= assertEqual "borkbo" [Match "bork", NoMatch "bor"] + + fromList ["borkborkborkb", "o", "r", "k", "b", "o"] + >>= search "borkborkbork" + >>= toList + >>= assertEqual "boooooork" [Match "borkborkbork", NoMatch "borkbo"] + + fromList ["bbbbb", "o", "r", "k", "bork"] + >>= search "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" + >>= toList + >>= assertEqual "bbbbbbbbb" [NoMatch "bbbbborkbork"] + + fromList ["bbbbbbbbb", "o", "r", "k"] + >>= search "bbbbbbbb" + >>= toList + >>= assertEqual "bbb2" [Match "bbbbbbbb", NoMatch "bork"] + + fromList ["bababa", "bo", "rk", "bz", "z", "z", "z"] >>= search "babababork" + >>= toList + >>= assertEqual "zzz" [Match "babababork", NoMatch "bzzzz"] + + fromList ["bab", "a", "b"] >>= search "bababa" + >>= toList + >>= assertEqual "bab" [NoMatch "babab"] + + fromList ["xxx", "xxxzx", "xx"] >>= search "xxxx" >>= toList + >>= assertEqual "xxxx" [Match "xxxx", NoMatch "xxzxxx"] + + +------------------------------------------------------------------------------ +testWriteLazyByteString :: Test +testWriteLazyByteString = testProperty "bytestring/writeLazy" $ + monadicIO $ + forAllM arbitrary prop + where + prop :: [ByteString] -> PropertyM IO () + prop l0 = liftQ $ do + let l = filter (not . S.null) l0 + let s = L.fromChunks l + (os, grab) <- listOutputStream + writeLazyByteString s os + + l' <- grab + assertEqual "writeLazy" l l' + + +------------------------------------------------------------------------------ +testReadExactly :: Test +testReadExactly = testProperty "bytestring/readExactly" $ + monadicIO $ + forAllM arbitrary prop + where + prop l0 = liftQ $ do + let l = filter (not . S.null) l0 + is <- fromList l + + let s = L.fromChunks l + let n = fromEnum $ L.length s + + t <- readExactly n is + assertEqual "eq" s $ L.fromChunks [t] + + unRead t is + expectExceptionH $ readExactly (n+1) is + + when (n > 0) $ do + is' <- fromList l + u <- readExactly (n-1) is' + assertEqual "eq2" (L.take (toEnum $ n-1) s) (L.fromChunks [u]) + v <- readExactly 1 is' + assertEqual "eq3" (L.drop (toEnum $ n-1) s) (L.fromChunks [v]) + + +------------------------------------------------------------------------------ +testTakeWhile :: Test +testTakeWhile = testCase "bytestring/takeBytesWhile" $ do + is <- fromList ["test", "ing\n", "1-2-3\n1-2-3"] + + takeBytesWhile (/= '\n') is >>= + assertEqual "takeBytesWhile1" (Just "testing") + takeBytesWhile (/= '\n') is >>= + assertEqual "takeBytesWhile2" (Just "") + readExactly 1 is >>= assertEqual "readExactly" "\n" + takeBytesWhile (/= '\n') is >>= + assertEqual "takeBytesWhile3" (Just "1-2-3") + readExactly 1 is >>= assertEqual "readExactly" "\n" + takeBytesWhile (/= '\n') is >>= + assertEqual "takeBytesWhile4" (Just "1-2-3") + takeBytesWhile (/= '\n') is >>= assertEqual "takeBytesWhile4" Nothing + + +------------------------------------------------------------------------------ +testLines :: Test +testLines = testCase "bytestring/testLines" $ do + fromList ["th", "e\nquick\nbrown", "\n", "", "fox"] >>= lines >>= + toList >>= assertEqual "lines" ["the", "quick", "brown", "fox"] + fromList [] >>= lines >>= toList >>= assertEqual "empty lines" [] + + fromList ["ok", "cool"] >>= + \is -> outputToList (\os -> unlines os >>= connect is) >>= + assertEqual "unlines" ["ok", "\n", "cool", "\n"] + + +------------------------------------------------------------------------------ +testWords :: Test +testWords = testCase "bytestring/testWords" $ do + fromList ["the quick brown \n\tfox"] >>= words >>= + toList >>= assertEqual "words" ["the", "quick", "brown", "fox"] + + fromList ["ok", "cool"] >>= + \is -> outputToList (\os -> unwords os >>= connect is) >>= + assertEqual "unlines" ["ok", " ", "cool"] + + +------------------------------------------------------------------------------ +testTrivials :: Test +testTrivials = testCase "bytestring/testTrivials" $ do + coverTypeableInstance (undefined :: TooManyBytesReadException) + coverShowInstance (undefined :: TooManyBytesReadException) + coverTypeableInstance (undefined :: TooFewBytesWrittenException) + coverShowInstance (undefined :: TooFewBytesWrittenException) + coverTypeableInstance (undefined :: TooManyBytesWrittenException) + coverShowInstance (undefined :: TooManyBytesWrittenException) + coverTypeableInstance (undefined :: RateTooSlowException) + coverShowInstance (undefined :: RateTooSlowException) + coverTypeableInstance (undefined :: ReadTooShortException) + + coverEqInstance $ Match "" + + coverShowInstance $ Match "" + coverShowInstance $ NoMatch "" diff --git a/test/System/IO/Streams/Tests/Combinators.hs b/test/System/IO/Streams/Tests/Combinators.hs new file mode 100644 --- /dev/null +++ b/test/System/IO/Streams/Tests/Combinators.hs @@ -0,0 +1,397 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module System.IO.Streams.Tests.Combinators (tests) where + +------------------------------------------------------------------------------ +import Control.Applicative +import Control.Monad hiding (filterM, mapM, + mapM_) +import qualified Control.Monad as CM +import Data.IORef +import Data.List hiding (drop, filter, + take, unzip, zip, + zipWith) +import Prelude hiding (drop, filter, + mapM, mapM_, read, take, + unzip, zip, zipWith) +import qualified Prelude +import System.IO.Streams hiding (all, any, maximum, + minimum) +import qualified System.IO.Streams as S +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit hiding (Test) +import Test.QuickCheck hiding (output) +import Test.QuickCheck.Monadic +------------------------------------------------------------------------------ +import System.IO.Streams.Tests.Common +------------------------------------------------------------------------------ + +tests :: [Test] +tests = [ testFilter + , testFilterM + , testFilterOutput + , testFilterOutputM + , testFoldMWorksTwice + , testFold + , testFoldM + , testUnfoldM + , testPredicates + , testMap + , testContramap + , testMapM + , testMapM_ + , testContramapM_ + , testSkipToEof + , testZip + , testZipWith + , testZipWithM + , testUnzip + , testTake + , testDrop + , testGive + , testIgnore + ] + + +------------------------------------------------------------------------------ +testFoldMWorksTwice :: Test +testFoldMWorksTwice = testCase "combinators/foldMWorksTwice" $ do + (os, grab) <- nullOutput >>= outputFoldM f (0::Int) + + let l = [1,2,3] + fromList l >>= supplyTo os + m <- grab + assertEqual "foldm1" (sum l) m + + let l2 = [4,5,6] + fromList l2 >>= supplyTo os + m2 <- grab + assertEqual "foldm2" (sum l2) m2 + + (is, grab2) <- fromList l >>= inputFoldM f (0::Int) + _ <- read is + x <- grab2 + assertEqual "foldm3" 1 x + + _ <- read is >> read is + y <- grab2 + assertEqual "foldm4" 5 y + + read is >>= assertEqual "eof" Nothing + + where + f a b = return (a+b) + + +------------------------------------------------------------------------------ +testMapM :: Test +testMapM = testCase "combinators/mapM" $ do + is <- fromList [1,2,3::Int] >>= mapM (return . (1+)) + l <- toList is + + assertEqual "mapM" [2,3,4] l + + +------------------------------------------------------------------------------ +testMap :: Test +testMap = testCase "combinators/map" $ do + is <- fromList [1,2,3::Int] >>= S.map (1+) + l <- toList is + + assertEqual "map" [2,3,4] l + + +------------------------------------------------------------------------------ +testContramap :: Test +testContramap = testCase "combinators/contramap" $ do + is <- fromList [1,2,3::Int] + l <- outputToList (contramap (+1) >=> connect is) + assertEqual "contramap" [2,3,4] l + + +------------------------------------------------------------------------------ +testMapM_ :: Test +testMapM_ = testCase "combinators/mapM_" $ do + ref <- newIORef 0 + is <- fromList [1,2,3::Int] >>= mapM_ (modifyIORef ref . (+)) + _ <- toList is + + readIORef ref >>= assertEqual "mapM_" 6 + + +------------------------------------------------------------------------------ +testContramapM_ :: Test +testContramapM_ = testCase "combinators/contramapM_" $ do + ref <- newIORef 0 + is <- fromList [1,2,3::Int] + _ <- outputToList (contramapM_ (modifyIORef ref . (+)) >=> connect is) + + readIORef ref >>= assertEqual "contramapM_" 6 + + +------------------------------------------------------------------------------ +testSkipToEof :: Test +testSkipToEof = testCase "combinators/skipToEof" $ do + is <- fromList [1,2,3::Int] + !_ <- skipToEof is + x <- read is + + assertEqual "skipToEof" Nothing x + + +------------------------------------------------------------------------------ +testFilter :: Test +testFilter = testCase "combinators/filter" $ do + is <- fromList [1..10::Int] + is' <- filter even is + + read is' >>= assertEqual "read1" (Just 2) + unRead 3 is' + + peek is >>= assertEqual "pushback" (Just 3) + toList is' >>= assertEqual "rest" [4,6..10] + + unRead 20 is' + + peek is >>= assertEqual "pushback2" (Just 20) + toList is' >>= assertEqual "rest2" [20] + toList is' >>= assertEqual "eof" [] + + +------------------------------------------------------------------------------ +testFilterM :: Test +testFilterM = testCase "combinators/filterM" $ do + is <- fromList [1..10::Int] + is' <- filterM (return . even) is + + read is' >>= assertEqual "read1" (Just 2) + unRead 3 is' + + peek is >>= assertEqual "pushback" (Just 3) + toList is' >>= assertEqual "rest" [4,6..10] + + unRead 20 is' + + peek is >>= assertEqual "pushback2" (Just 20) + toList is' >>= assertEqual "rest2" [20] + toList is' >>= assertEqual "eof" [] + + +------------------------------------------------------------------------------ +testFilterOutput :: Test +testFilterOutput = testCase "combinators/filterOutput" $ do + is <- fromList [1..10::Int] + l <- outputToList (\os -> filterOutput even os >>= connect is) + assertEqual "filterOutput" (Prelude.filter even [1..10]) l + + +------------------------------------------------------------------------------ +testFilterOutputM :: Test +testFilterOutputM = testCase "combinators/filterOutputM" $ do + is <- fromList [1..10::Int] + l <- outputToList (\os -> filterOutputM (return . even) os >>= connect is) + assertEqual "filterOutputM" (Prelude.filter even [1..10]) l + + +------------------------------------------------------------------------------ +testFold :: Test +testFold = testCase "combinators/fold" $ do + fromList [1..10::Int] >>= S.fold (+) 0 + >>= assertEqual "fold1" (sum [1..10]) + +------------------------------------------------------------------------------ +testFoldM :: Test +testFoldM = testCase "combinators/foldM" $ do + fromList [1..10::Int] >>= S.foldM ((return .) . (+)) 0 + >>= assertEqual "fold2" (sum [1..10]) + + +------------------------------------------------------------------------------ +testUnfoldM :: Test +testUnfoldM = testCase "combinators/unfoldM" $ do + S.unfoldM gen 0 >>= toList >>= assertEqual "unfold" result + where + gen !n = return $! if n < 10 then Just (n, n + 1) else Nothing + result = [0, 1 .. 9 :: Int] + + +------------------------------------------------------------------------------ +data StreamPred = forall c . (Eq c, Show c) => + P ([Int] -> c, InputStream Int -> IO c, String) + +testPredicates :: Test +testPredicates = testProperty "combinators/predicates" $ monadicIO $ forAllM arbitrary prop + where + predicates :: [StreamPred] + predicates = [ P (all even , S.all even , "all" ) + , P (any even , S.any even , "any" ) + , P (nl maximum , S.maximum , "maximum" ) + , P (nl minimum , S.minimum , "minimum" ) + ] + + nl f l = if null l then Nothing else Just (f l) + + prop :: [Int] -> PropertyM IO () + prop l = liftQ $ CM.mapM_ (p l) predicates + + p :: [Int] -> StreamPred -> IO () + p l (P (pPred, pStream, name)) = + fromList l >>= pStream >>= assertEqual name (pPred l) + + +------------------------------------------------------------------------------ +testZipWithM :: Test +testZipWithM = testCase "combinators/zipWithM" $ do + let l1 = [1 .. 10 :: Int] + let l2 = [2 .. 10 :: Int] + + (join $ S.zipWithM ((return .) . (+)) <$> fromList l1 <*> fromList l2) + >>= toList >>= assertEqual "zipWith1" (Prelude.zipWith (+) l1 l2) + + (join $ S.zipWithM ((return .) . (+)) <$> fromList l2 <*> fromList l1) + >>= toList >>= assertEqual "zipWith1" (Prelude.zipWith (+) l2 l1) + is1 <- fromList l1 + is2 <- fromList l2 + isZip <- S.zipWithM ((return .) . (+)) is1 is2 + + _ <- toList isZip + read is1 >>= assertEqual "remainder" (Just 10) + + +------------------------------------------------------------------------------ +testZipWith :: Test +testZipWith = testCase "combinators/zipWith" $ do + let l1 = [1 .. 10 :: Int] + let l2 = [2 .. 10 :: Int] + + (join $ S.zipWith (+) <$> fromList l1 <*> fromList l2) + >>= toList >>= assertEqual "zipWith1" (Prelude.zipWith (+) l1 l2) + + (join $ S.zipWith (+) <$> fromList l2 <*> fromList l1) + >>= toList >>= assertEqual "zipWith1" (Prelude.zipWith (+) l2 l1) + is1 <- fromList l1 + is2 <- fromList l2 + isZip <- S.zipWith (+) is1 is2 + + _ <- toList isZip + read is1 >>= assertEqual "remainder" (Just 10) + + +------------------------------------------------------------------------------ +testZip :: Test +testZip = testCase "combinators/zip" $ do + let l1 = [1 .. 10 :: Int] + let l2 = [2 .. 10 :: Int] + + (join $ zip <$> fromList l1 <*> fromList l2) >>= toList + >>= assertEqual "zip1" (Prelude.zip l1 l2) + + (join $ zip <$> fromList l2 <*> fromList l1) >>= toList + >>= assertEqual "zip2" (Prelude.zip l2 l1) + + is1 <- fromList l1 + is2 <- fromList l2 + isZip <- zip is1 is2 + + _ <- toList isZip + read is1 >>= assertEqual "remainder" (Just 10) + + +------------------------------------------------------------------------------ +testUnzip :: Test +testUnzip = testCase "combinators/unzip" $ do + let l1 = [1 .. 10 :: Int] + l2 = [2 .. 10 :: Int] + l = Prelude.zip l1 l2 + + (is1, is2) <- fromList l >>= unzip + toList is1 >>= assertEqual "unzip1-a" (fst $ Prelude.unzip l) + toList is2 >>= assertEqual "unzip1-b" (snd $ Prelude.unzip l) + read is1 >>= assertEqual "unzip1-read-a" Nothing + read is2 >>= assertEqual "unzip1-read-b" Nothing + + (is3, is4) <- fromList l >>= unzip + toList is4 >>= assertEqual "unzip2-b" (snd $ Prelude.unzip l) + toList is3 >>= assertEqual "unzip2-a" (fst $ Prelude.unzip l) + read is4 >>= assertEqual "unzip2-read-b" Nothing + read is3 >>= assertEqual "unzip2-read" Nothing + + +------------------------------------------------------------------------------ +testTake :: Test +testTake = testCase "combinators/take" $ do + fromList ([]::[Int]) >>= take 0 >>= toList >>= assertEqual "empty 0" [] + fromList ([]::[Int]) >>= take 10 >>= toList >>= assertEqual "empty 10" [] + + forM_ [0..4] $ \n -> fromList [1,2,3::Int] >>= + take n >>= + toList >>= + assertEqual ("for " ++ show n) + (Prelude.take (fromEnum n) [1..3]) + + is <- fromList [1,2,3::Int] + is' <- take 2 is + void $ read is' + unRead 0 is' + peek is >>= assertEqual "pb" (Just 0) + toList is' >>= assertEqual "toList" [0,2] + unRead 7 is' + peek is >>= assertEqual "pb2" (Just 7) + toList is' >>= assertEqual "toList2" [7] + + +------------------------------------------------------------------------------ +testDrop :: Test +testDrop = testCase "combinators/drop" $ do + fromList ([]::[Int]) >>= take 0 >>= toList >>= assertEqual "empty 0" [] + fromList ([]::[Int]) >>= take 10 >>= toList >>= assertEqual "empty 10" [] + + forM_ [0..4] $ \n -> fromList [1,2,3::Int] >>= + drop n >>= + toList >>= + assertEqual ("for " ++ show n) + (Prelude.drop (fromEnum n) [1..3]) + + is <- fromList [1,2,3::Int] + is' <- drop 1 is + read is' >>= assertEqual "read" (Just 2) + unRead 0 is' + peek is >>= assertEqual "pb" (Just 0) + toList is' >>= assertEqual "toList" [0,3] + unRead 7 is' + peek is >>= assertEqual "pb2" (Just 7) + toList is' >>= assertEqual "toList2" [7] + toList is' >>= assertEqual "toList2_empty" [] + + is2 <- fromList [1,2,3::Int] + is2' <- drop 1 is2 + read is2' >>= assertEqual "read2" (Just 2) + unRead 2 is2' + unRead 1 is2' + unRead 0 is2' + toList is2' >>= assertEqual "toList3" [2,3] + + +------------------------------------------------------------------------------ +testGive :: Test +testGive = testCase "combinators/give" $ forM_ [0..12] tgive + where + tgive n = fromList [1..10::Int] >>= \is -> + outputToList (\os -> give n os >>= connect is) >>= + assertEqual ("give" ++ show n) + (Prelude.take (fromEnum n) [1..10]) + + +------------------------------------------------------------------------------ +testIgnore :: Test +testIgnore = testCase "combinators/ignore" $ forM_ [0..12] tign + where + tign n = fromList [1..10::Int] >>= \is -> + outputToList (\os -> ignore n os >>= connect is) >>= + assertEqual ("ignore" ++ show n) + (Prelude.drop (fromEnum n) [1..10]) diff --git a/test/System/IO/Streams/Tests/Common.hs b/test/System/IO/Streams/Tests/Common.hs new file mode 100644 --- /dev/null +++ b/test/System/IO/Streams/Tests/Common.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module System.IO.Streams.Tests.Common where + +------------------------------------------------------------------------------ +import Control.DeepSeq +import Control.Exception +import qualified Control.Exception as E +import Control.Monad +import Control.Monad.Trans +import qualified Data.ByteString as S +import Data.ByteString.Internal (c2w) +import qualified Data.ByteString.Lazy as L +import Data.Typeable +import Test.QuickCheck +import Test.QuickCheck.Monadic +import qualified Test.QuickCheck.Monadic as QC + + +------------------------------------------------------------------------------ +instance Arbitrary S.ByteString where + arbitrary = liftM (S.pack . map c2w) arbitrary + +instance Arbitrary L.ByteString where + arbitrary = do + n <- choose(0,5) + chunks <- replicateM n arbitrary + return $ L.fromChunks chunks + + +------------------------------------------------------------------------------ +eatException :: IO a -> IO () +eatException a = (a >> return ()) `E.catch` handler + where + handler :: SomeException -> IO () + handler _ = return () + + +------------------------------------------------------------------------------ +forceSameType :: a -> a -> a +forceSameType _ a = a + + +------------------------------------------------------------------------------ +-- | Kill the false negative on derived show instances. +coverShowInstance :: (MonadIO m, Show a) => a -> m () +coverShowInstance x = liftIO (a >> b >> c) + where + a = eatException $ evaluate $ showsPrec 0 x "" + b = eatException $ evaluate $ show x + c = eatException $ evaluate $ showList [x] "" + + +------------------------------------------------------------------------------ +coverReadInstance :: (MonadIO m, Read a) => a -> m () +coverReadInstance x = do + liftIO $ eatException $ evaluate $ forceSameType [(x,"")] $ readsPrec 0 "" + liftIO $ eatException $ evaluate $ forceSameType [([x],"")] $ readList "" + + +------------------------------------------------------------------------------ +coverEqInstance :: (Monad m, Eq a) => a -> m () +coverEqInstance x = a `seq` b `seq` return () + where + a = x == x + b = x /= x + + +------------------------------------------------------------------------------ +coverOrdInstance :: (Monad m, Ord a) => a -> m () +coverOrdInstance x = a `deepseq` b `deepseq` return () + where + a = [ x < x + , x >= x + , x > x + , x <= x + , compare x x == EQ ] + + b = min a $ max a a + + +------------------------------------------------------------------------------ +coverTypeableInstance :: (Monad m, Typeable a) => a -> m () +coverTypeableInstance a = typeOf a `seq` return () + + +------------------------------------------------------------------------------ +expectException :: IO a -> PropertyM IO () +expectException m = do + e <- liftQ $ try m + case e of + Left (z::SomeException) -> (length $ show z) `seq` return () + Right _ -> fail "expected exception, didn't get one" + + +------------------------------------------------------------------------------ +expectExceptionH :: IO a -> IO () +expectExceptionH act = do + e <- try act + case e of + Left (z::SomeException) -> (length $ show z) `seq` return () + Right _ -> fail "expected exception, didn't get one" + + +------------------------------------------------------------------------------ +liftQ :: forall a m . (Monad m) => m a -> PropertyM m a +liftQ = QC.run diff --git a/test/System/IO/Streams/Tests/Debug.hs b/test/System/IO/Streams/Tests/Debug.hs new file mode 100644 --- /dev/null +++ b/test/System/IO/Streams/Tests/Debug.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module System.IO.Streams.Tests.Debug (tests) where + +------------------------------------------------------------------------------ +import qualified Data.ByteString.Char8 as S +import qualified System.IO.Streams as Streams +import qualified System.IO.Streams.Debug as Streams +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + + +------------------------------------------------------------------------------ +tests :: [Test] +tests = [ testDebugInput + , testDebugOutput + ] + + +------------------------------------------------------------------------------ +testDebugInput :: Test +testDebugInput = testCase "debug/input" $ do + s <- Streams.fromList [S.replicate 100 'a', "foo"] + (ds, getDebugOutput) <- Streams.listOutputStream + s' <- Streams.debugInputBS "foo" ds s + Streams.unRead "blah" s' + Streams.skipToEof s' + + l <- getDebugOutput + + assertEqual "debugInput" expected l + where + expected = [ + "foo: pushback: \"blah\"\n" + , "foo: got chunk: \"blah\"\n" + , "foo: got chunk: \"aaaaaaaaaaaaaa ... aaaaaaaaaaaaaa\" (100 bytes)\n" + , "foo: got chunk: \"foo\"\n" + , "foo: got EOF\n" + ] + + +------------------------------------------------------------------------------ +testDebugOutput :: Test +testDebugOutput = testCase "debug/output" $ do + is <- Streams.fromList [S.replicate 100 'a', "foo"] + o <- Streams.makeOutputStream f + (ds, getDebugOutput) <- Streams.listOutputStream + o' <- Streams.debugOutputBS "foo" ds o + Streams.connect is o' + + l <- getDebugOutput + + assertEqual "debugInput" expected l + where + f !_ = return () + + expected = [ + "foo: got chunk: \"aaaaaaaaaaaaaa ... aaaaaaaaaaaaaa\" (100 bytes)\n" + , "foo: got chunk: \"foo\"\n" + , "foo: got EOF\n" + ] + diff --git a/test/System/IO/Streams/Tests/File.hs b/test/System/IO/Streams/Tests/File.hs new file mode 100644 --- /dev/null +++ b/test/System/IO/Streams/Tests/File.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module System.IO.Streams.Tests.File (tests) where + +------------------------------------------------------------------------------ +import Control.Concurrent +import Control.Exception +import Control.Monad hiding (mapM) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Data.List +import Prelude hiding (mapM, read) +import System.Directory +import System.FilePath +import System.IO +import System.IO.Streams hiding (intersperse, mapM_) +import System.IO.Streams.Internal +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +------------------------------------------------------------------------------ +import System.IO.Streams.Tests.Common + +tests :: [Test] +tests = [ testFiles + , testBigFiles + ] + + +------------------------------------------------------------------------------ +copyingListOutputStream :: IO (OutputStream ByteString, IO [ByteString]) +copyingListOutputStream = do + r <- newMVar id + c <- sinkToStream $ consumer r + return (c, flush r) + + where + consumer r = Sink $ maybe (return nullSink) + (\c0 -> do + let !c = S.copy c0 + modifyMVar_ r $ \dl -> return (dl . (c:)) + return $ consumer r) + + flush r = modifyMVar r $ \dl -> return (id, dl []) + + +------------------------------------------------------------------------------ +testFiles :: Test +testFiles = testCase "file/files" $ do + createDirectoryIfMissing False "tmp" + sequence_ [tst1, tst2, tst3, tst4, tst5] `finally` cleanup + + where + fn x = ("tmp" "data") ++ show (x :: Int) + + cleanup = eatException $ do + mapM_ (eatException . removeFile . fn) [1, 2, 3, 4, 5] + removeDirectory "tmp" + + tst mode n = do + withFileAsOutputExt (fn n) mode (BlockBuffering $ Just 2048) $ \os -> do + let l = "" : (intersperse " " ["the", "quick", "brown", "fox"]) + fromList l >>= connectTo os + + l <- liftM S.concat $ withFileAsInput (fn n) toList + assertEqual "testFiles" "the quick brown fox" l + + tst1 = tst WriteMode 1 + tst2 = tst AppendMode 2 + tst3 = tst ReadWriteMode 3 + tst4 = expectExceptionH (tst ReadMode 4) + tst5 = do + withFileAsOutput (fn 5) $ \os -> do + let l = "" : (intersperse " " ["the", "quick", "brown", "fox"]) + fromList l >>= connectTo os + + l <- liftM S.concat $ withFileAsInput (fn 5) toList + assertEqual "testFiles" "the quick brown fox" l + + +------------------------------------------------------------------------------ +testBigFiles :: Test +testBigFiles = testCase "file/bigFiles" $ do + createDirectoryIfMissing False "tmp2" + tst `finally` eatException (removeFile fn >> removeDirectory "tmp2") + + where + fn = "tmp2" "data" + + testSz = 20 * 1024 * 1024 + + tst = do + let l = L.take testSz $ L.cycle $ + L.fromChunks (intersperse " " ["the", "quick", "brown", "fox"]) + + withFileAsOutputExt fn WriteMode NoBuffering $ \os -> do + fromList [S.concat $ L.toChunks l] >>= connectTo os + + l1 <- liftM L.fromChunks $ withFileAsInput fn toList + assertBool "testFiles2" (l1 == l) + + l2 <- liftM L.fromChunks $ withFileAsInputStartingAt 5 fn toList + assertBool "testFiles3" (l2 == (L.drop 5 l)) + + (os, grab) <- copyingListOutputStream + unsafeWithFileAsInputStartingAt 0 fn (connectTo os) + + l3 <- liftM L.fromChunks grab + assertBool "testFiles4" (l3 == l) diff --git a/test/System/IO/Streams/Tests/Handle.hs b/test/System/IO/Streams/Tests/Handle.hs new file mode 100644 --- /dev/null +++ b/test/System/IO/Streams/Tests/Handle.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.IO.Streams.Tests.Handle (tests) where + +------------------------------------------------------------------------------ +import Control.Exception +import Control.Monad hiding (mapM) +import qualified Data.ByteString.Char8 as S +import Data.List +import Prelude hiding (mapM, read) +import System.Directory +import System.FilePath +import System.IO hiding (stderr, stdin, stdout) +import qualified System.IO as IO +import System.IO.Streams hiding (intersperse) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +------------------------------------------------------------------------------ +import System.IO.Streams.Tests.Common + +tests :: [Test] +tests = [ testHandle + , testStdHandles ] + + +------------------------------------------------------------------------------ +testHandle :: Test +testHandle = testCase "handle/files" $ do + createDirectoryIfMissing False "tmp" + tst `finally` eatException (removeFile fn >> removeDirectory "tmp") + + where + fn = "tmp" "data" + + tst = do + withBinaryFile fn WriteMode $ \h -> do + let l = "" : (intersperse " " ["the", "quick", "brown", "fox"]) + os <- handleToOutputStream h + fromList l >>= connectTo os + + withBinaryFile fn ReadMode $ \h -> do + l <- liftM S.concat (handleToInputStream h >>= toList) + assertEqual "testFiles" "the quick brown fox" l + + +------------------------------------------------------------------------------ +testStdHandles :: Test +testStdHandles = testCase "handle/stdHandles" $ do + hClose IO.stdin + -- Should generate exception: handle is closed. + expectExceptionH (toList stdin) + write (Just "") stdout + write (Just "") stderr + return () diff --git a/test/System/IO/Streams/Tests/Internal.hs b/test/System/IO/Streams/Tests/Internal.hs new file mode 100644 --- /dev/null +++ b/test/System/IO/Streams/Tests/Internal.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module System.IO.Streams.Tests.Internal (tests) where + +------------------------------------------------------------------------------ +import Control.Applicative +import Control.Monad hiding (mapM) +import Control.Monad.IO.Class (liftIO) +import Data.IORef +import Data.Monoid +import Prelude hiding (mapM, read) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +------------------------------------------------------------------------------ +import System.IO.Streams.Internal +import System.IO.Streams.List + +tests :: [Test] +tests = [ testSourceConcat + , testAppendInput + , testConst + , testCoverLockingStream + , testPeek + , testNullInput + , testGenerator + , testGeneratorInstances + , testGeneratorSource + , testConsumer + ] + + +------------------------------------------------------------------------------ +testSourceConcat :: Test +testSourceConcat = testCase "internal/sourceConcat" $ do + is <- sourceToStream $ mconcat $ + map singletonSource [1::Int, 2, 3] + + unRead 7 is + + l <- toList is + + assertEqual "sourceConcat" [7,1,2,3] l + + is' <- sourceToStream $ mconcat $ + map singletonSource [1::Int, 2, 3] + + unRead 7 is' + + l' <- toList is' + + assertEqual "sourceConcat2" [7,1,2,3] l' + + +------------------------------------------------------------------------------ +testAppendInput :: Test +testAppendInput = testCase "internal/appendInputStream" $ do + s1 <- fromList [1::Int, 2, 3] + s2 <- fromList [5, 6, 7] + + is <- appendInputStream s1 s2 + l <- toList is + + assertEqual "appendInputStream" [1,2,3,5,6,7] l + + +------------------------------------------------------------------------------ +testConst :: Test +testConst = testCase "internal/const" $ do + is <- makeInputStream (return (Just (1::Int))) + read is >>= assertEqual "const" (Just 1) + + unRead 7 is + read is >>= assertEqual "unRead" (Just 7) + read is >>= assertEqual "const2" (Just 1) + + +------------------------------------------------------------------------------ +testNullInput :: Test +testNullInput = testCase "internal/nullInput" $ do + is <- nullInput + xs <- replicateM 10 $ read (is :: InputStream Int) + assertEqual "nullInput" (replicate 10 Nothing) xs + + +------------------------------------------------------------------------------ +testCoverLockingStream :: Test +testCoverLockingStream = testCase "internal/coverLockingStreams" $ do + is <- fromList [1::Int, 2, 3] >>= lockingInputStream + (os0, grab) <- listOutputStream + os <- lockingOutputStream os0 + + connect is os + xs <- grab + + assertEqual "lockingStreams" [1,2,3] xs + + write Nothing os + write Nothing os + + unRead 7 is + y <- read is + assertEqual "unRead" (Just 7) y + + +------------------------------------------------------------------------------ +testPeek :: Test +testPeek = testCase "internal/peek" $ do + is <- fromList [1::Int, 2, 3] + b <- atEOF is + assertEqual "eof1" False b + + x0 <- peek is + x1 <- peek is + + unRead 7 is + x2 <- peek is + + assertEqual "peek" (map Just [1, 1, 7]) [x0, x1, x2] + + l <- toList is + assertEqual "toList" [7, 1, 2, 3] l + + z <- peek is + assertEqual "peekEOF" Nothing z + + b' <- atEOF is + assertEqual "eof2" True b' + + +------------------------------------------------------------------------------ +testGenerator :: Test +testGenerator = testCase "internal/generator" $ do + is <- fromGenerator $ sequence $ + Prelude.map ((>>= yield) . (liftIO . return)) [1..5::Int] + toList is >>= assertEqual "generator" [1..5] + read is >>= assertEqual "read after EOF" Nothing + + +------------------------------------------------------------------------------ +testGeneratorSource :: Test +testGeneratorSource = testCase "internal/generatorSource" $ do + let src = generatorToSource $ sequence $ + Prelude.map ((>>= yield) . (liftIO . return)) [1..5::Int] + is <- sourceToStream src + toList is >>= assertEqual "generator" [1..5] + read is >>= assertEqual "read after EOF" Nothing + + +------------------------------------------------------------------------------ +testGeneratorInstances :: Test +testGeneratorInstances = testCase "internal/generatorInstances" $ do + fromGenerator g1 >>= toList + >>= assertEqual "generator" [2,4..10] + + fromGenerator g2 >>= toList + >>= assertEqual "generator" [2,4..10] + + where + g1 = do + l <- fmap (map (*2)) $ return [1..5::Int] + fmap id $ sequence_ $ Prelude.map yield l + + g2 = pure id <*> g1 + + +------------------------------------------------------------------------------ +testConsumer :: Test +testConsumer = testCase "internal/consumer" $ do + is <- fromList [1..10::Int] + ref <- newIORef 0 + os <- fromConsumer (fmap id (pure id <*> c ref)) + connect is os + readIORef ref >>= assertEqual "sum" (sum [1..10]) + + -- should be nullsink after receiving Nothing + write (Just 2) os + readIORef ref >>= assertEqual "sum" (sum [1..10]) + + is2 <- fromList [1..10::Int] + os2 <- fromConsumer (return ()) + connect is2 os2 + + where + c ref = await >>= maybe (return ()) + (\x -> do + !t <- liftIO $ readIORef ref + liftIO $ writeIORef ref $! t + x + c ref) diff --git a/test/System/IO/Streams/Tests/List.hs b/test/System/IO/Streams/Tests/List.hs new file mode 100644 --- /dev/null +++ b/test/System/IO/Streams/Tests/List.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.IO.Streams.Tests.List (tests) where + +------------------------------------------------------------------------------ +import Control.Monad hiding (mapM) +import Prelude hiding (mapM, read) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +------------------------------------------------------------------------------ +import System.IO.Streams.List +------------------------------------------------------------------------------ +import System.IO.Streams.Tests.Common (expectExceptionH) + +tests :: [Test] +tests = [ testChunkJoin ] + + +testChunkJoin :: Test +testChunkJoin = testCase "list/chunkList and join" $ do + expectExceptionH (fromList [1..10::Int] >>= chunkList 0 >>= toList) + + fromList [1..10 :: Int] >>= chunkList 3 + >>= toList + >>= assertEqual "chunkList" [ [1,2,3] + , [4,5,6] + , [7,8,9] + , [10] + ] + fromList [1..12 :: Int] >>= chunkList 3 + >>= concatLists + >>= toList + >>= assertEqual "concatlists" [1..12] diff --git a/test/System/IO/Streams/Tests/Network.hs b/test/System/IO/Streams/Tests/Network.hs new file mode 100644 --- /dev/null +++ b/test/System/IO/Streams/Tests/Network.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.IO.Streams.Tests.Network (tests) where + +------------------------------------------------------------------------------ +import Control.Concurrent (forkIO, newEmptyMVar, + putMVar, takeMVar) +import qualified Network.Socket as N +import System.Timeout (timeout) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +------------------------------------------------------------------------------ +import qualified System.IO.Streams.Internal as Streams +import qualified System.IO.Streams.List as Streams +import qualified System.IO.Streams.Network as Streams +------------------------------------------------------------------------------ + +tests :: [Test] +tests = [ testSocket ] + +testSocket :: Test +testSocket = testCase "network/socket" $ + N.withSocketsDo $ do + x <- timeout (10 * 10^(6::Int)) go + assertEqual "ok" (Just ()) x + + where + go = do + portMVar <- newEmptyMVar + resultMVar <- newEmptyMVar + forkIO $ client portMVar resultMVar + server portMVar + l <- takeMVar resultMVar + assertEqual "testSocket" l ["ok"] + + client mvar resultMVar = do + port <- takeMVar mvar + sock <- N.socket N.AF_INET N.Stream N.defaultProtocol + addr <- N.inet_addr "127.0.0.1" + let saddr = N.SockAddrInet port addr + N.connect sock saddr + (is, os) <- Streams.socketToStreams sock + Streams.fromList ["", "ok"] >>= Streams.connectTo os + N.shutdown sock N.ShutdownSend + Streams.toList is >>= putMVar resultMVar + N.close sock + + server mvar = do + sock <- N.socket N.AF_INET N.Stream N.defaultProtocol + addr <- N.inet_addr "127.0.0.1" + let saddr = N.SockAddrInet N.aNY_PORT addr + N.bind sock saddr + N.listen sock 5 + port <- N.socketPort sock + putMVar mvar port + (csock, _) <- N.accept sock + (is, os) <- Streams.socketToStreams csock + Streams.toList is >>= flip Streams.writeList os + N.close csock + N.close sock diff --git a/test/System/IO/Streams/Tests/Text.hs b/test/System/IO/Streams/Tests/Text.hs new file mode 100644 --- /dev/null +++ b/test/System/IO/Streams/Tests/Text.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.IO.Streams.Tests.Text (tests) where + +------------------------------------------------------------------------------ +import Control.Monad ((>=>)) +import Data.Text.Encoding.Error +import qualified System.IO.Streams.Internal as Streams +import qualified System.IO.Streams.List as Streams +import System.IO.Streams.Tests.Common +import qualified System.IO.Streams.Text as Streams +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +------------------------------------------------------------------------------ + +tests :: [Test] +tests = [ testDecodeOK + , testStrictDecodeError + , testEncode + ] + + +------------------------------------------------------------------------------ +testEncode :: Test +testEncode = testCase "text/encodeUtf8" $ do + is <- Streams.fromList ["\x3BC", "ok", ""] + Streams.outputToList (Streams.encodeUtf8 >=> Streams.connect is) + >>= assertEqual "ok encode" ["\xCE\xBC", "ok", ""] + + +------------------------------------------------------------------------------ +testDecodeOK :: Test +testDecodeOK = testCase "text/decodeUtf8/wholeChunk" $ do + Streams.fromList ["\xCE\xBC", "ok", ""] + >>= Streams.decodeUtf8 + >>= Streams.toList + >>= assertEqual "ok decode" ["\x3BC", "ok", ""] + + Streams.fromList ["\xCE", "\xBC", "ok", "foo\xCE", "\xBC"] + >>= Streams.decodeUtf8 + >>= Streams.toList + >>= assertEqual "ok decode 2" ["\x3BC", "ok", "foo", "\x3BC"] + + Streams.fromList ["\xE2\xB6", "\x8E"] + >>= Streams.decodeUtf8 + >>= Streams.toList + >>= assertEqual "ok decode 3" ["\x2D8E"] + + Streams.fromList ["\xF0\x90\x80\x83"] + >>= Streams.decodeUtf8 + >>= Streams.toList + >>= assertEqual "ok decode 4" ["\x10003"] + + Streams.fromList [] + >>= Streams.decodeUtf8With strictDecode + >>= Streams.toList + >>= assertEqual "ok strict empty" [] + + +------------------------------------------------------------------------------ +testStrictDecodeError :: Test +testStrictDecodeError = testCase "text/decodeUtf8/error" $ do + expectExceptionH (Streams.fromList ["\x87"] >>= + Streams.decodeUtf8With strictDecode >>= + Streams.toList) + expectExceptionH (Streams.fromList ["o\x87\x87"] >>= + Streams.decodeUtf8With strictDecode >>= + Streams.toList) diff --git a/test/System/IO/Streams/Tests/Vector.hs b/test/System/IO/Streams/Tests/Vector.hs new file mode 100644 --- /dev/null +++ b/test/System/IO/Streams/Tests/Vector.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.IO.Streams.Tests.Vector (tests) where + +------------------------------------------------------------------------------ +import Control.Monad hiding (mapM) +import qualified Data.Vector as V +import Prelude hiding (mapM, read) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +------------------------------------------------------------------------------ +import qualified System.IO.Streams as S +import System.IO.Streams.List +import System.IO.Streams.Vector +------------------------------------------------------------------------------ +import System.IO.Streams.Tests.Common (expectExceptionH) + + +------------------------------------------------------------------------------ +tests :: [Test] +tests = [ testChunk + , testWrite + , testVectorOutputStream + , testFromTo + , testOutputToMutableVector + , testToMutableVector + ] + + +------------------------------------------------------------------------------ +testChunk :: Test +testChunk = testCase "vector/chunkVector" $ do + let zeroLen :: IO ([V.Vector Int]) + zeroLen = fromList [1..10::Int] >>= chunkVector 0 >>= toList + expectExceptionH zeroLen + + fromList [1..10 :: Int] >>= chunkVector 3 + >>= toList + >>= assertEqual "chunkVector" + (map V.fromList [ [1,2,3] + , [4,5,6] + , [7,8,9] + , [10] + ]) + fromList [1..12 :: Int] >>= chunkVector 3 + >>= toList + >>= assertEqual "chunkVector2" + (map V.fromList [ [1,2,3] + , [4,5,6] + , [7,8,9] + , [10,11,12] + ]) + + +------------------------------------------------------------------------------ +testWrite :: Test +testWrite = testCase "vector/writeVector" $ + outputToVector act >>= + assertEqual "testWrite" (V.fromList [1..10::Int]) + where + act str = do + writeVector (V.fromList [1..10]) str + S.write Nothing str + S.write Nothing str + + +------------------------------------------------------------------------------ +testVectorOutputStream :: Test +testVectorOutputStream = testCase "vector/vectorOutputStream" $ test1 >> test2 + where + test1 = do + (os, flush) <- vectorOutputStream + fromList [1,2,3::Int] >>= S.connectTo os + flush >>= assertEqual "v1" (V.fromList [1,2,3::Int]) + S.write (Just 4) os + flush >>= assertEqual "v2" V.empty + + test2 = do + (os, flush) <- mutableVectorOutputStream + fromList [1,2,3::Int] >>= S.supplyTo os + flush >>= V.unsafeFreeze + >>= assertEqual "v1" (V.fromList [1,2,3::Int]) + S.write (Just 4) os + flush >>= V.unsafeFreeze + >>= assertEqual "v2" (V.singleton (4::Int)) + + +------------------------------------------------------------------------------ +testFromTo :: Test +testFromTo = testCase "vector/fromVector" $ do + fromVector V.empty >>= toVector + >>= assertEqual "f1" (V.empty :: V.Vector Int) + fromVector vtest >>= toVector >>= assertEqual "f2" vtest + + where + vtest = V.fromList [1..100::Int] + + +------------------------------------------------------------------------------ +testOutputToMutableVector :: Test +testOutputToMutableVector = testCase "vector/outputToMutableVector" $ do + is <- S.fromList [1::Int,2,3] + outputToMutableVector (S.connect is) + >>= V.unsafeFreeze + >>= assertEqual "outputToMutableVector" (V.fromList [1,2,3]) + + +------------------------------------------------------------------------------ +testToMutableVector :: Test +testToMutableVector = testCase "vector/toMutableVector" $ do + is <- S.fromList [1::Int,2,3] + toMutableVector is + >>= V.unsafeFreeze + >>= assertEqual "toMutableVector" (V.fromList [1,2,3]) diff --git a/test/System/IO/Streams/Tests/Zlib.hs b/test/System/IO/Streams/Tests/Zlib.hs new file mode 100644 --- /dev/null +++ b/test/System/IO/Streams/Tests/Zlib.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.IO.Streams.Tests.Zlib (tests) where + +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder +import qualified Codec.Compression.GZip as GZ +import qualified Codec.Compression.Zlib as Z +import Control.Monad hiding (mapM) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Prelude hiding (mapM, read) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit hiding (Test) +import Test.QuickCheck hiding (output) +import Test.QuickCheck.Monadic +------------------------------------------------------------------------------ +import System.IO.Streams hiding (fromByteString) +import System.IO.Streams.Tests.Common + +tests :: [Test] +tests = [ testIdGzip + , testIdCompress + , testBigString + , testBuilderFlushGZip + , testBuilderFlushCompress + , testTrivials + ] + + +------------------------------------------------------------------------------ +testIdGzip :: Test +testIdGzip = testProperty "zlib/idGZip" $ monadicIO $ forAllM arbitrary prop + where + prop :: [ByteString] -> PropertyM IO () + prop l = propId "idGZip" GZ.decompress GZ.compress gunzip gzip l + + +------------------------------------------------------------------------------ +testIdCompress :: Test +testIdCompress = testProperty "zlib/idCompress" $ monadicIO $ + forAllM arbitrary prop + where + prop :: [ByteString] -> PropertyM IO () + prop l = propId "idCompress" Z.decompress Z.compress + decompress compress l + + +------------------------------------------------------------------------------ +propId :: String + -> (L.ByteString -> L.ByteString) + -> (L.ByteString -> L.ByteString) + -> (InputStream ByteString -> IO (InputStream ByteString)) + -> (CompressionLevel -> OutputStream ByteString + -> IO (OutputStream ByteString)) + -> [ByteString] + -> PropertyM IO () +propId name inf def infStr defStr l0 = do + pre (not (null l0) && L.length (L.fromChunks l0) > 0) + liftQ $ do + let l = L.fromChunks $ l0 ++ + [ S.concat $ L.toChunks $ L.take 32000 $ L.fromChunks $ + cycle l0 ] + let inp = def l + + is <- fromList (L.toChunks inp) >>= infStr + (os0, grab) <- listOutputStream + os <- defStr defaultCompressionLevel os0 + + connect is os + outp <- liftM L.fromChunks grab + + assertEqual name l (inf outp) + + + +------------------------------------------------------------------------------ +testBigString :: Test +testBigString = testCase "zlib/bigString" $ do + let l = S.concat $ L.toChunks $ L.take 640000 $ L.fromChunks $ cycle + [ "lfkdsjflkdshflkjdhsfkljhdslkfhdslakjfhlkdsjhflkjdsahflkjhsa" + , "39287647893264987368947632198746328974698327649873216498713" + , "bznmbxz879hJKHYG^&%^&^%*&^%*&^%*&^%&*^%&*65tykjhdgbmdnvkjch" + , "VBUYDUHKJC*(HJKDHLCJBUYEOUIHJCHUOY&*^(*)@HJDNM>= connectTo os + + out <- liftM L.fromChunks grab + + + + let o1 = L.fromChunks [l] + let o2 = GZ.decompress out + + when (o1 /= o2) $ do + putStrLn "o1 /= o2" + putStrLn $ "o1 = " ++ (show $ S.concat $ L.toChunks $ L.take 1000 o1) + ++ "..." + putStrLn $ "o2 = " ++ (show $ S.concat $ L.toChunks $ L.take 1000 o2) + ++ "..." + + putStrLn $ "len(o1)=" ++ show (L.length o1) + putStrLn $ "len(o2)=" ++ show (L.length o2) + + assertBool "bigString1" $ o1 == o2 + + is2 <- fromList ([""] ++ L.toChunks out ++ [""]) >>= gunzip + (os1, grab') <- listOutputStream + connect is2 os1 + out' <- liftM L.fromChunks grab' + + assertBool "bigString2" $ o1 == out' + + + +------------------------------------------------------------------------------ +testBuilderFlushGZip :: Test +testBuilderFlushGZip = testProperty "zlib/builderFlushGZip" $ monadicIO $ + forAllM arbitrary prop + where + prop :: (ByteString, ByteString) -> PropertyM IO () + prop (a,b) = propBuilderFlush "gzip" GZ.decompress gzipBuilder a b + + +------------------------------------------------------------------------------ +testBuilderFlushCompress :: Test +testBuilderFlushCompress = testProperty "zlib/builderFlushCompress" $ + monadicIO $ forAllM arbitrary prop + where + prop :: (ByteString, ByteString) -> PropertyM IO () + prop (a,b) = propBuilderFlush "zlib" Z.decompress compressBuilder a b + + +------------------------------------------------------------------------------ +propBuilderFlush :: String + -> (L.ByteString -> L.ByteString) + -> (CompressionLevel + -> OutputStream Builder -> IO (OutputStream Builder)) + -> ByteString + -> ByteString + -> PropertyM IO () +propBuilderFlush name inf comp a b = do + pre (not (S.null a) && not (S.null b)) + liftQ $ do + t 7 [ fromByteString a, flush, flush, fromByteString b + , flush, flush ] + + t 4 [ fromByteString a, flush, flush, fromByteString b ] + + where + t expected input = do + (os0, grab) <- listOutputStream + os <- builderStream os0 >>= comp defaultCompressionLevel + + fromList input >>= connectTo os + xs <- grab + + when (length xs /= expected) $ putStrLn $ "xs is " ++ show xs + assertEqual (name ++ "/len") expected (length xs) + + let outp = inf $ L.fromChunks xs + + assertEqual (name ++ "/eq") (L.fromChunks [a,b]) outp + + +------------------------------------------------------------------------------ +testTrivials :: Test +testTrivials = testCase "zlib/trivials" $ do + let cl = CompressionLevel 4 + coverReadInstance cl + coverShowInstance cl + coverEqInstance cl diff --git a/test/TestSuite.hs b/test/TestSuite.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite.hs @@ -0,0 +1,36 @@ +module Main where + +import qualified System.IO.Streams.Tests.Attoparsec as Attoparsec +import qualified System.IO.Streams.Tests.Builder as Builder +import qualified System.IO.Streams.Tests.ByteString as ByteString +import qualified System.IO.Streams.Tests.Combinators as Combinators +import qualified System.IO.Streams.Tests.Debug as Debug +import qualified System.IO.Streams.Tests.File as File +import qualified System.IO.Streams.Tests.Handle as Handle +import qualified System.IO.Streams.Tests.Internal as Internal +import qualified System.IO.Streams.Tests.List as List +import qualified System.IO.Streams.Tests.Network as Network +import qualified System.IO.Streams.Tests.Text as Text +import qualified System.IO.Streams.Tests.Vector as Vector +import qualified System.IO.Streams.Tests.Zlib as Zlib +import Test.Framework (defaultMain, testGroup) + + +------------------------------------------------------------------------------ +main :: IO () +main = defaultMain tests + where + tests = [ testGroup "Tests.Attoparsec" Attoparsec.tests + , testGroup "Tests.Builder" Builder.tests + , testGroup "Tests.ByteString" ByteString.tests + , testGroup "Tests.Debug" Debug.tests + , testGroup "Tests.Combinators" Combinators.tests + , testGroup "Tests.File" File.tests + , testGroup "Tests.Handle" Handle.tests + , testGroup "Tests.Internal" Internal.tests + , testGroup "Tests.List" List.tests + , testGroup "Tests.Network" Network.tests + , testGroup "Tests.Text" Text.tests + , testGroup "Tests.Vector" Vector.tests + , testGroup "Tests.Zlib" Zlib.tests + ]