io-streams (empty) → 1.0.0.0
raw patch · 39 files changed
+7269/−0 lines, 39 filesdep +HUnitdep +QuickCheckdep +attoparsecsetup-changed
Dependencies added: HUnit, QuickCheck, attoparsec, base, blaze-builder, bytestring, deepseq, directory, filepath, mtl, network, primitive, test-framework, test-framework-hunit, test-framework-quickcheck2, text, time, transformers, vector, zlib, zlib-bindings
Files
- CONTRIBUTORS +36/−0
- LICENSE +29/−0
- README.md +22/−0
- Setup.hs +2/−0
- io-streams.cabal +218/−0
- src/System/IO/Streams.hs +145/−0
- src/System/IO/Streams/Attoparsec.hs +11/−0
- src/System/IO/Streams/Builder.hs +187/−0
- src/System/IO/Streams/ByteString.hs +747/−0
- src/System/IO/Streams/Combinators.hs +763/−0
- src/System/IO/Streams/Concurrent.hs +99/−0
- src/System/IO/Streams/Core.hs +43/−0
- src/System/IO/Streams/Debug.hs +105/−0
- src/System/IO/Streams/File.hs +93/−0
- src/System/IO/Streams/Handle.hs +76/−0
- src/System/IO/Streams/Internal.hs +724/−0
- src/System/IO/Streams/Internal/Attoparsec.hs +130/−0
- src/System/IO/Streams/Internal/Search.hs +208/−0
- src/System/IO/Streams/List.hs +177/−0
- src/System/IO/Streams/Network.hs +35/−0
- src/System/IO/Streams/Text.hs +138/−0
- src/System/IO/Streams/Tutorial.hs +441/−0
- src/System/IO/Streams/Vector.hs +354/−0
- src/System/IO/Streams/Zlib.hs +213/−0
- test/System/IO/Streams/Tests/Attoparsec.hs +111/−0
- test/System/IO/Streams/Tests/Builder.hs +128/−0
- test/System/IO/Streams/Tests/ByteString.hs +611/−0
- test/System/IO/Streams/Tests/Combinators.hs +397/−0
- test/System/IO/Streams/Tests/Common.hs +108/−0
- test/System/IO/Streams/Tests/Debug.hs +64/−0
- test/System/IO/Streams/Tests/File.hs +111/−0
- test/System/IO/Streams/Tests/Handle.hs +55/−0
- test/System/IO/Streams/Tests/Internal.hs +190/−0
- test/System/IO/Streams/Tests/List.hs +34/−0
- test/System/IO/Streams/Tests/Network.hs +61/−0
- test/System/IO/Streams/Tests/Text.hs +69/−0
- test/System/IO/Streams/Tests/Vector.hs +115/−0
- test/System/IO/Streams/Tests/Zlib.hs +183/−0
- test/TestSuite.hs +36/−0
+ CONTRIBUTORS view
@@ -0,0 +1,36 @@+------------------------------------------------------------------------------+IOStreams Contributors:++ - Gregory Collins <greg@gregorycollins.net>+ - Gabriel Gonzalez <gabriel439@gmail.com>++------------------------------------------------------------------------------+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.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ io-streams.cabal view
@@ -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 <greg@gregorycollins.net>+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
+ src/System/IO/Streams.hs view
@@ -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 <http://github.com/snapframework/io-streams>.+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.+--+
+ src/System/IO/Streams/Attoparsec.hs view
@@ -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
+ src/System/IO/Streams/Builder.hs view
@@ -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'
+ src/System/IO/Streams/ByteString.hs view
@@ -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))
+ src/System/IO/Streams/Combinators.hs view
@@ -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\<Enter>+-- ghci> Streams.'System.IO.Streams.write' (Just 4) os2+-- Allow 4?+-- True\<Enter>+-- 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
+ src/System/IO/Streams/Concurrent.hs view
@@ -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
+ src/System/IO/Streams/Core.hs view
@@ -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
+ src/System/IO/Streams/Debug.hs view
@@ -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
+ src/System/IO/Streams/File.hs view
@@ -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
+ src/System/IO/Streams/Handle.hs view
@@ -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 #-}
+ src/System/IO/Streams/Internal.hs view
@@ -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)+-- @
+ src/System/IO/Streams/Internal/Attoparsec.hs view
@@ -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 #-}
+ src/System/IO/Streams/Internal/Search.hs view
@@ -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+-- (<http://en.wikipedia.org/wiki/Boyer%E2%80%93Moore%E2%80%93Horspool_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:)
+ src/System/IO/Streams/List.hs view
@@ -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
+ src/System/IO/Streams/Network.hs view
@@ -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
+ src/System/IO/Streams/Text.hs view
@@ -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 #-}
+ src/System/IO/Streams/Tutorial.hs view
@@ -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+-- @
+ src/System/IO/Streams/Vector.hs view
@@ -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
+ src/System/IO/Streams/Zlib.hs view
@@ -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
+ test/System/IO/Streams/Tests/Attoparsec.hs view
@@ -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
+ test/System/IO/Streams/Tests/Builder.hs view
@@ -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
+ test/System/IO/Streams/Tests/ByteString.hs view
@@ -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 ""
+ test/System/IO/Streams/Tests/Combinators.hs view
@@ -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])
+ test/System/IO/Streams/Tests/Common.hs view
@@ -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
+ test/System/IO/Streams/Tests/Debug.hs view
@@ -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"+ ]+
+ test/System/IO/Streams/Tests/File.hs view
@@ -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)
+ test/System/IO/Streams/Tests/Handle.hs view
@@ -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 ()
+ test/System/IO/Streams/Tests/Internal.hs view
@@ -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)
+ test/System/IO/Streams/Tests/List.hs view
@@ -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]
+ test/System/IO/Streams/Tests/Network.hs view
@@ -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
+ test/System/IO/Streams/Tests/Text.hs view
@@ -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)
+ test/System/IO/Streams/Tests/Vector.hs view
@@ -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])
+ test/System/IO/Streams/Tests/Zlib.hs view
@@ -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<NCKJHVUKHLKJ"+ , "())))))A(JXNZMWJ#*&^&YIUHDHKJHKJLNCnkfdhkfy32huukhksnc8310s"+ , "|||||A!@2iuozukx|djklu8udjlm3n3888****8ijlfkdjvnchiuyuis';'"+ , "56%^%^%^%^4dnmcnjjk3NJKNKJCiejnhfj[]][}{[][]f[][]d]299ikkjn"+ , "fjlkdjklfozi898888****2jkmdc,x.//,.,/asl;oi39uijdp'''qwjkjh"+ ]++ (os0, grab) <- listOutputStream+ os <- gzip 5 os0++ fromList [l] >>= 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
+ test/TestSuite.hs view
@@ -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+ ]