io-streams-1.5.1.0/0000755000000000000000000000000013423613322012124 5ustar0000000000000000io-streams-1.5.1.0/README.md0000644000000000000000000000203413423613322013402 0ustar0000000000000000The 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`. io-streams-1.5.1.0/Setup.hs0000644000000000000000000000005613423613322013561 0ustar0000000000000000import Distribution.Simple main = defaultMain io-streams-1.5.1.0/io-streams.cabal0000644000000000000000000002171613423613322015202 0ustar0000000000000000Name: io-streams Version: 1.5.1.0 License: BSD3 License-file: LICENSE Category: Data, Network, IO-Streams Build-type: Simple Maintainer: Gregory Collins Cabal-version: >= 1.10 Synopsis: Simple, composable, and easy-to-use stream I/O Tested-With: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.3 Bug-Reports: https://github.com/snapframework/io-streams/issues 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.read :: InputStream a -> IO (Maybe a) . \-\- push an item back to an input stream Streams.unRead :: a -> InputStream a -> IO () . \-\- write to an output stream Streams.write :: Maybe a -> 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> Streams.read wrapped Just \"long\" ghci> Streams.read wrapped Nothing ghci> Streams.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@. . * support for spawning processes and communicating with them using streams. Extra-Source-Files: CONTRIBUTORS README.md changelog.md Flag NoInteractiveTests Description: Do not run interactive tests Default: False ------------------------------------------------------------------------------ Library hs-source-dirs: src Default-language: Haskell2010 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind Exposed-modules: System.IO.Streams, System.IO.Streams.Attoparsec, System.IO.Streams.Attoparsec.ByteString, System.IO.Streams.Attoparsec.Text, 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.Process, 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.Network, System.IO.Streams.Internal.Search Build-depends: base >= 4 && <5, attoparsec >= 0.10 && <0.14, bytestring >= 0.9 && <0.11, bytestring-builder >= 0.10 && <0.11, network >= 2.3 && <3.1, primitive >= 0.2 && <0.7, process >= 1.1 && <1.7, text >= 0.10 && <1.3, time >= 1.2 && <1.10, transformers >= 0.2 && <0.6, vector >= 0.7 && <0.13, zlib-bindings >= 0.1 && <0.2 if impl(ghc >= 7.2) other-extensions: Trustworthy other-extensions: BangPatterns, CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings, RankNTypes, TypeSynonymInstances ------------------------------------------------------------------------------ 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.ByteString, System.IO.Streams.Tests.Attoparsec.Text, System.IO.Streams.Tests.Builder, System.IO.Streams.Tests.ByteString, System.IO.Streams.Tests.Combinators, System.IO.Streams.Tests.Common, System.IO.Streams.Tests.Concurrent, 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.Process, System.IO.Streams.Tests.Text, System.IO.Streams.Tests.Vector, System.IO.Streams.Tests.Zlib, System.IO.Streams, System.IO.Streams.Attoparsec.ByteString, System.IO.Streams.Attoparsec.Text, 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.Process, 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.Network, System.IO.Streams.Internal.Search ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind ghc-prof-options: -auto-all if !os(windows) && !flag(NoInteractiveTests) cpp-options: -DENABLE_PROCESS_TESTS Build-depends: base, attoparsec, bytestring, bytestring-builder, deepseq >= 1.2 && <1.5, directory >= 1.1 && <2, filepath >= 1.2 && <2, mtl >= 2 && <3, network, primitive, process, text, time, transformers, vector, zlib-bindings, HUnit >= 1.2 && <2, QuickCheck >= 2.3.0.2 && <3, test-framework >= 0.6 && <0.9, test-framework-hunit >= 0.2.7 && <0.4, test-framework-quickcheck2 >= 0.2.12.1 && <0.4, zlib >= 0.5 && <0.7 if impl(ghc >= 7.2) other-extensions: Trustworthy other-extensions: BangPatterns, CPP, DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings, RankNTypes source-repository head type: git location: https://github.com/snapframework/io-streams.git io-streams-1.5.1.0/changelog.md0000644000000000000000000001415213423613322014400 0ustar0000000000000000# Version 1.5.1.0 Fix [stackage#4312](https://github.com/commercialhaskell/stackage/issues/4312): Relax `network` upper bound # Version 1.5.0.1 Bugfix: `concurrentMerge []` should not block forever, even if this case is pathological. # Version 1.5.0.0 - Changed the behaviour of `ByteString.splitOn` to not emit empty string if the input ends in the delimiter; now `lines` should match Prelude's. Bumped major version because this is a potentially breaking change (even if it is a bugfix.) # Version 1.4.1.0 - Added `writeTo` export to the main module (forgotten when it was added to `.Core`.) # Version 1.4.0.0 - Added support for Text with Attoparsec, courtesy Kevin Brubeck Unhammer. Adds modules `System.IO.Streams.Attoparsec.{ByteString, Text}` and deprecates `System.IO.Streams.Attoparsec`, which is now a thin wrapper. # Version 1.3.6.1 - Bumped dependencies on `time` and `process`. # Version 1.3.6.0 - Added new fold functions: ```haskell fold_ :: (x -> a -> x) -- ^ accumulator update function -> x -- ^ initial seed -> (x -> s) -- ^ recover folded value -> InputStream a -- ^ input stream -> IO s foldM_ :: (x -> a -> IO x) -- ^ accumulator update action -> IO x -- ^ initial seed -> (x -> IO s) -- ^ recover folded value -> InputStream a -- ^ input stream -> IO s ``` # Version 1.3.5.0 - Add support for latest `process`, `time`, and `transformers` releases (and thereby indirectly for the upcoming GHC 8.0). # Version 1.3.4.0 - Added `System.IO.Streams.Handle.handleToStreams`, to conveniently create an `InputStream`/`OutputStream` pair. # Version 1.3.3.1 - Fixed a testsuite compile error on GHC >= 7.10. # Version 1.3.3.0 - Added a new convenience function, like `chunkList` but with a predicate for when to split, taking current element and current chunk length: ```haskell chunkListWith :: (a -> Int -> Bool) -> InputStream a -> IO (InputStream [a]) ``` # Version 1.3.2.0 - Dependency bump for attoparsec 0.13 (another location) - Dependency bump for vector 0.11 - Dependency bump for zlib 0.6 # Version 1.3.1.0 - Dependency bump for attoparsec 0.13. # Version 1.3.0.0 - As long promised, removed the direct use of the `blaze-builder` package in favor of the new `bytestring-builder` transitional package (to be replaced by bytestring's native builder once it is mature enough). - Added a new convenience function, a flipped version of `write`: ```haskell writeTo :: OutputStream a -> Maybe a -> IO () ``` # Version 1.2.1.3 - Dependency bump for primitive 0.6. # Version 1.2.1.2 - Dependency bump for deepseq 1.4. # Version 1.2.1.1 - Dependency bump for time 1.6. # Version 1.2.1.0 - Added `System.IO.Streams.mapMaybe` for InputStream. - Added `System.IO.Streams.contramapMaybe` for OutputStream. # Version 1.2.0.1 - `System.IO.Streams.Attoparsec.parseFromStream`: export more information about the context of parse errors to the message returned via `ParseException`. - Improved documentation about stream flushing in the docstring for `handleToOutputStream`. # Version 1.2.0.0 - Fixed bug #27 (https://github.com/snapframework/io-streams/issues/27): makeOutputStream now properly shuts down the stream upon receiving EOF. The new invariant might break user programs if they depended on the buggy behaviour, which is the reason for the major version bump. - Fixed a few polymorphic bindings that started breaking in recent GHC. - Dependency bumps for: - text 1.2 - network 2.6 # Version 1.1.4.6 Moved old changelog entries to `changelog.md`. # Version 1.1.4.5 Allow use of attoparsec 0.12.*. # Version 1.1.4.4 Allow use of transformers 0.4.*. # Version 1.1.4.3 Allow use of new network version 2.5. # Version 1.1.4.2 Fixed a build error with network versions older than 2.4. # Version 1.1.4.1 `System.IO.Streams.Network`: scalability improvement: buffers for socket reads are now allocated by system malloc rather than by pinned pointers in GHC (currently pinned pointer allocation takes a global lock). # Version 1.1.4.0 Widened `attoparsec` and `text` library dependencies to allow the latest versions. # Version 1.1.3.0 Added `System.IO.Streams.ByteString.takeExactly`. Widened `network` dependency to include 2.3. Added a `NoInteractiveTests` flag to selectively disable some tests for environments where spawning interactive processes is impossible. # Version 1.1.2.2 Allowed newest versions of the `process`, `test-framework`, and `text` libraries. # Version 1.1.2.1 Fixed build error when compiled against attoparsec-0.10.0.x. # Version 1.1.2.0 Added `System.IO.Streams.Concurrent.makeChanPipe`, to create a simple concurrent pipe between an `InputStream`/`OutputStream` pair. # Version 1.1.1.0 Added `System.IO.Streams.Network.socketToStreamsWithBufferSize`, allowing control over the size of the receive buffers used when reading from sockets. # Version 1.1.0.3 Fixed an inconsistent version upper bound in the test suite. # Version 1.1.0.2 Fixed a typo in the tutorial. # Version 1.1.0.1 A couple of Haddock markup fixes. # Version 1.1.0.0 Reworked, simplified, and streamlined the internals of the library. Exports from `System.IO.Streams.Internal` relying on Sources and Sinks were deleted because they are no longer necessary: `Source(..)`, `Sink(..)`, `defaultPushback`, `withDefaultPushback`, `nullSource`, `nullSink`, `singletonSource`, `simpleSource`, `sourceToStream`, `sinkToStream`, `generatorToSource`, and `consumerToSink`. # Version 1.0.2.2 Fixed a bug in which `"takeBytes 0"` was erroneously requesting input from the wrapped stream. # Version 1.0.2.1 Fixed a compile error on GHC 7.0.x. # Version 1.0.2.0 Added `System.IO.Streams.Process` (support for communicating with system processes using streams), added new functions to `System.IO.Streams.Handle` for converting `io-streams` types to `System.IO.Handle`s. (Now you can pass streams from this library to places that expect Handles and everything will work.) # Version 1.0.1.0 Added `System.IO.Streams.Combinators.ignoreEof`. # Version 1.0.0.1 Fixed some haddock markup. io-streams-1.5.1.0/LICENSE0000644000000000000000000000274113423613322013135 0ustar0000000000000000Copyright (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. io-streams-1.5.1.0/CONTRIBUTORS0000644000000000000000000000354213423613322014010 0ustar0000000000000000------------------------------------------------------------------------------ IOStreams Contributors: - Gregory Collins - Gabriel Gonzalez ------------------------------------------------------------------------------ Contains some code ported from the "blaze-builder-enumerator" package by Simon Meier and Thomas Sutton, distributed under the following license: Copyright 2010, Thomas Sutton. All rights reserved. Copyright 2011, Simon Meier. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * The names of its contributors may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ''AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. io-streams-1.5.1.0/test/0000755000000000000000000000000013423613322013103 5ustar0000000000000000io-streams-1.5.1.0/test/TestSuite.hs0000644000000000000000000000445013423613322015373 0ustar0000000000000000module Main where import qualified System.IO.Streams.Tests.Attoparsec.ByteString as AttoparsecByteString import qualified System.IO.Streams.Tests.Attoparsec.Text as AttoparsecText 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.Concurrent as Concurrent 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.Process as Process 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.ByteString" AttoparsecByteString.tests , testGroup "Tests.Attoparsec.Text" AttoparsecText.tests , testGroup "Tests.Builder" Builder.tests , testGroup "Tests.ByteString" ByteString.tests , testGroup "Tests.Debug" Debug.tests , testGroup "Tests.Combinators" Combinators.tests , testGroup "Tests.Concurrent" Concurrent.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.Process" Process.tests , testGroup "Tests.Text" Text.tests , testGroup "Tests.Vector" Vector.tests , testGroup "Tests.Zlib" Zlib.tests ] io-streams-1.5.1.0/test/System/0000755000000000000000000000000013423613322014367 5ustar0000000000000000io-streams-1.5.1.0/test/System/IO/0000755000000000000000000000000013423613322014676 5ustar0000000000000000io-streams-1.5.1.0/test/System/IO/Streams/0000755000000000000000000000000013423613322016314 5ustar0000000000000000io-streams-1.5.1.0/test/System/IO/Streams/Tests/0000755000000000000000000000000013423613322017416 5ustar0000000000000000io-streams-1.5.1.0/test/System/IO/Streams/Tests/Handle.hs0000644000000000000000000002001513423613322021143 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module System.IO.Streams.Tests.Handle (tests) where ------------------------------------------------------------------------------ import Control.Exception import Control.Monad hiding (mapM) import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Char8 as S import Data.List import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Marshal.Utils (copyBytes) import Foreign.Ptr (castPtr) import qualified GHC.IO.Buffer as HB import qualified GHC.IO.BufferedIO as H import qualified GHC.IO.Device as H 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 (OutputStream) import qualified System.IO.Streams as Streams import qualified System.IO.Streams.Internal as Streams import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) ------------------------------------------------------------------------------ import System.IO.Streams.Tests.Common tests :: [Test] tests = [ testHandle , testStdHandles , testRepeatedConnects , testInputStreamToHandle , testOutputStreamToHandle , testStreamPairToHandle , testHandleInstances , testHandleBadnesses ] ------------------------------------------------------------------------------ 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 <- Streams.handleToOutputStream h Streams.fromList l >>= Streams.connectTo os withBinaryFile fn ReadMode $ \h -> do l <- liftM S.concat (Streams.handleToInputStream h >>= Streams.toList) assertEqual "testFiles" "the quick brown fox" l ------------------------------------------------------------------------------ testRepeatedConnects :: Test testRepeatedConnects = testCase "handle/repeatedConnects" $ do createDirectoryIfMissing False dirname tst `finally` eatException (removeFile fn >> removeDirectory dirname) where dirname = "tmp_r_c" fn = dirname "data" tst = do withBinaryFile fn WriteMode $ \h -> do os0 <- Streams.handleToOutputStream h os <- Streams.builderStream os0 let l1 = map byteString ["the ", "quick ", "brown "] let l2 = map byteString ["fox ", "jumped"] Streams.fromList l1 >>= Streams.connectTo os Streams.fromList l2 >>= Streams.connectTo os S.readFile fn >>= assertEqual "eof should close" "the quick brown " ------------------------------------------------------------------------------ testStdHandles :: Test testStdHandles = testCase "handle/stdHandles" $ do hClose IO.stdin -- Should generate exception: handle is closed. expectExceptionH (Streams.toList Streams.stdin) Streams.write (Just "") Streams.stdout Streams.write (Just "") Streams.stderr return () ------------------------------------------------------------------------------ testInputStreamToHandle :: Test testInputStreamToHandle = testCase "handle/inputStreamToHandle" $ do h <- Streams.fromList ["foo", "bar", "baz"] >>= Streams.inputStreamToHandle S.hGetContents h >>= assertEqual "inputStreamToHandle" "foobarbaz" ------------------------------------------------------------------------------ testOutputStreamToHandle :: Test testOutputStreamToHandle = testCase "handle/outputStreamToHandle" $ do (os, getInput) <- Streams.listOutputStream h <- Streams.outputStreamToHandle os S.hPutStrLn h "foo" liftM S.concat getInput >>= assertEqual "outputStreamToHandle" "foo\n" ------------------------------------------------------------------------------ testStreamPairToHandle :: Test testStreamPairToHandle = testCase "handle/streamPairToHandle" $ do is <- Streams.fromList ["foo", "bar", "baz"] (os, getInput) <- Streams.listOutputStream h <- Streams.streamPairToHandle is os S.hPutStrLn h "foo" S.hGetContents h >>= assertEqual "input stream" "foobarbaz" liftM S.concat getInput >>= assertEqual "output stream" "foo\n" ------------------------------------------------------------------------------ testHandleBadnesses :: Test testHandleBadnesses = testCase "handle/badness" $ do h <- Streams.fromList ["foo", "bar", "baz"] >>= Streams.inputStreamToHandle _ <- S.hGetContents h expectExceptionH $ S.hGetContents h h' <- Streams.fromList ["foo", "bar", "baz"] >>= Streams.inputStreamToHandle expectExceptionH $ S.hPutStrLn h' "foo" (os, _) <- Streams.listOutputStream h'' <- Streams.outputStreamToHandle os expectExceptionH $ S.hGetContents h'' is <- Streams.fromList ["foo"] h''' <- Streams.streamPairToHandle is os _ <- S.hGetContents h''' expectExceptionH $ S.hGetContents h''' ------------------------------------------------------------------------------ testHandleInstances :: Test testHandleInstances = testCase "handle/ghc-instances" $ do is <- Streams.fromList ["foo", "bar", "baz" :: S.ByteString] (os, getList) <- Streams.listOutputStream let sp = Streams.SP is (os :: OutputStream S.ByteString) expectExceptionH $ H.write is undefined undefined expectExceptionH $ H.writeNonBlocking is undefined undefined expectExceptionH $ H.flushWriteBuffer is undefined expectExceptionH $ H.flushWriteBuffer0 is undefined expectExceptionH $ H.read os undefined undefined expectExceptionH $ H.writeNonBlocking os undefined undefined expectExceptionH $ H.fillReadBuffer0 is undefined expectExceptionH $ H.fillReadBuffer0 os undefined expectExceptionH $ H.fillReadBuffer0 sp undefined H.ready is False 0 >>= assertEqual "ready input" True H.ready os False 0 >>= assertEqual "ready output" True H.ready sp False 0 >>= assertEqual "ready pair" True H.devType is >>= assertBool "devtype input" . (== H.Stream) H.devType os >>= assertBool "devtype output" . (== H.Stream) H.devType sp >>= assertBool "devtype pair" . (== H.Stream) expectExceptionH $ H.readNonBlocking is undefined undefined expectExceptionH $ H.readNonBlocking os undefined undefined expectExceptionH $ H.readNonBlocking sp undefined undefined expectExceptionH $ H.writeNonBlocking is undefined undefined expectExceptionH $ H.writeNonBlocking os undefined undefined expectExceptionH $ H.writeNonBlocking sp undefined undefined S.useAsCStringLen "foo" $ \(cstr, l) -> do H.write os (castPtr cstr) l liftM S.concat getList >>= assertEqual "H.write 1" "foo" H.write sp (castPtr cstr) l liftM S.concat getList >>= assertEqual "H.write 2" "foo" buf <- H.newBuffer sp HB.WriteBuffer HB.withBuffer buf $ \ptr -> copyBytes ptr (castPtr cstr) 3 (l', !buf') <- H.flushWriteBuffer0 sp $ buf { HB.bufR = 3 } assertEqual "flushWriteBuffer0" 3 l' assertEqual "bufR" 0 $ HB.bufR buf' liftM S.concat getList >>= assertEqual "write 3" "foo" allocaBytes 3 $ \buf -> do l <- H.read is buf 3 assertEqual "3 byte read" 3 l S.packCStringLen (castPtr buf, l) >>= assertEqual "first read" "foo" l' <- H.read sp buf 3 assertEqual "3 byte read #2" 3 l' S.packCStringLen (castPtr buf, l') >>= assertEqual "second read" "bar" expectExceptionH $ H.read os buf 3 io-streams-1.5.1.0/test/System/IO/Streams/Tests/Common.hs0000644000000000000000000000701713423613322021207 0ustar0000000000000000{-# 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 io-streams-1.5.1.0/test/System/IO/Streams/Tests/Text.hs0000644000000000000000000000501313423613322020675 0ustar0000000000000000{-# 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) io-streams-1.5.1.0/test/System/IO/Streams/Tests/Vector.hs0000644000000000000000000001052413423613322021216 0ustar0000000000000000{-# 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]) io-streams-1.5.1.0/test/System/IO/Streams/Tests/Debug.hs0000644000000000000000000000365613423613322021012 0ustar0000000000000000{-# 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" ] io-streams-1.5.1.0/test/System/IO/Streams/Tests/Combinators.hs0000644000000000000000000003723213423613322022241 0ustar0000000000000000{-# 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 , testFold_ , testFoldM_ , testUnfoldM , testPredicates , testMap , testContramap , testMapM , testMapM_ , testMapMaybe , testContramapM_ , testContramapMaybe , testSkipToEof , testZip , testZipWith , testZipWithM , testUnzip , testTake , testDrop , testGive , testIgnore , testIgnoreEof , testAtEnd ] ------------------------------------------------------------------------------ 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 ------------------------------------------------------------------------------ testMapMaybe :: Test testMapMaybe = testCase "combinators/mapMaybe" $ do is <- fromList [1,2,3::Int] >>= S.mapMaybe (\x -> if odd x then Just (x * x) else Nothing) l <- toList is assertEqual "mapMaybe" [1,9] l ------------------------------------------------------------------------------ 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 ------------------------------------------------------------------------------ testContramapMaybe :: Test testContramapMaybe = testCase "combinators/contramapMaybe" $ do is <- fromList [1,2,3::Int] l <- outputToList (contramapMaybe f >=> connect is) assertEqual "contramapMaybe" [1,9] l where f x = if even x then Nothing else Just $ x * x ------------------------------------------------------------------------------ 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]) ------------------------------------------------------------------------------ testFold_ :: Test testFold_ = testCase "combinators/fold_" $ do fromList [1..10::Int] >>= S.fold_ (+) 0 id >>= assertEqual "fold_1" (sum [1..10]) ------------------------------------------------------------------------------ testFoldM_ :: Test testFoldM_ = testCase "combinators/foldM_" $ do fromList [1..10::Int] >>= S.foldM_ ((return .) . (+)) (return 0) return >>= assertEqual "fold_2" (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]) ------------------------------------------------------------------------------ testIgnoreEof :: Test testIgnoreEof = testCase "combinators/ignoreEof" $ do eofRef <- newIORef 0 chunkRef <- newIORef [] str0 <- S.makeOutputStream $ f eofRef chunkRef str <- S.ignoreEof str0 S.write (Just 0) str S.write Nothing str readIORef eofRef >>= assertEqual "eof ignored" (0::Int) readIORef chunkRef >>= assertEqual "input propagated" [0::Int] where f ref _ Nothing = modifyIORef ref (+1) f _ chunk (Just x) = modifyIORef chunk (++ [x]) ------------------------------------------------------------------------------ testAtEnd :: Test testAtEnd = testCase "combinators/atEndOfInput" $ do boolRef <- newIORef False is <- fromList [1,2,3::Int] >>= atEndOfInput (writeIORef boolRef True) unRead 0 is toList is >>= assertEqual "list" [0,1,2,3] readIORef boolRef >>= assertBool "ran" toList is >>= assertEqual "list 2" [] unRead 0 is toList is >>= assertEqual "list 3" [0] io-streams-1.5.1.0/test/System/IO/Streams/Tests/Network.hs0000644000000000000000000000752413423613322021413 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module System.IO.Streams.Tests.Network (tests) where ------------------------------------------------------------------------------ import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar) import Control.Monad (join) import qualified Data.ByteString.Char8 as S import Data.IORef (atomicModifyIORef, newIORef) import qualified Network.Socket as N import System.IO.Error (eofErrorType, mkIOError) import System.Timeout (timeout) import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) #if MIN_VERSION_network(2,7,0) #else import Data.List (intercalate) #endif ------------------------------------------------------------------------------ import qualified System.IO.Streams.Internal as Streams import qualified System.IO.Streams.Internal.Network as Streams import qualified System.IO.Streams.List as Streams ------------------------------------------------------------------------------ import System.IO.Streams.Tests.Common (expectExceptionH) tests :: [Test] tests = [ testSocket , testSocketWithError ] testSocket :: Test testSocket = testCase "network/socket" $ N.withSocketsDo $ do x <- timeout (10 * 10^(6::Int)) go assertEqual "ok" (Just ()) x where -- compats #if MIN_VERSION_network(2,7,0) mkAddr = return . N.tupleToHostAddress defaultPort = N.defaultPort close = N.close bind = N.bind #else mkAddr (o1,o2,o3,o4) = N.inet_addr . intercalate "." $ map show [o1,o2,o3,o4] defaultPort = N.aNY_PORT close = N.sClose bind = N.bindSocket #endif 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 <- mkAddr (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 close sock server mvar = do sock <- N.socket N.AF_INET N.Stream N.defaultProtocol addr <- mkAddr (127, 0, 0, 1) let saddr = N.SockAddrInet defaultPort addr 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 close csock close sock testSocketWithError :: Test testSocketWithError = testCase "network/socket-error" $ N.withSocketsDo $ do codes1 <- newIORef [ return 1 , ioError $ mkIOError eofErrorType "eof" Nothing Nothing ] codes2 <- newIORef [ return 1 , ioError $ userError "foo" ] (is1, _) <- Streams.socketToStreamsWithBufferSizeImpl (rbuf codes1) 64 (error "z") (Just s1) <- Streams.read is1 assertEqual "one byte" 1 $ S.length s1 Nothing <- Streams.read is1 (is2, _) <- Streams.socketToStreamsWithBufferSizeImpl (rbuf codes2) 64 undefined (Just s2) <- Streams.read is2 assertEqual "one byte" 1 $ S.length s2 expectExceptionH $ Streams.read is2 where rbuf rcodes _ _ _ = join $ atomicModifyIORef rcodes $ \codes -> (tail codes, head codes) io-streams-1.5.1.0/test/System/IO/Streams/Tests/File.hs0000644000000000000000000000673413423613322020643 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module System.IO.Streams.Tests.File (tests) where ------------------------------------------------------------------------------ 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 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 (os, grab) <- listOutputStream os' <- contramap S.copy os >>= lockingOutputStream return (os', grab) ------------------------------------------------------------------------------ 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) io-streams-1.5.1.0/test/System/IO/Streams/Tests/Zlib.hs0000644000000000000000000001512413423613322020655 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module System.IO.Streams.Tests.Zlib (tests) where ------------------------------------------------------------------------------ import qualified Codec.Compression.GZip as GZ import qualified Codec.Compression.Zlib as Z import Control.Monad hiding (mapM) import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Builder.Extra (flush) 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 import System.IO.Streams.Tests.Common tests :: [Test] tests = [ testIdGzip , testIdCompress , testBigString , testBuilderFlushGZip , testBuilderFlushCompress , testTrivials ] ------------------------------------------------------------------------------ testIdGzip :: Test testIdGzip = testProperty "zlib/idGZip" $ monadicIO $ forAllM arbitrary prop where prop :: [ByteString] -> PropertyM IO () prop l = propId "idGZip" GZ.decompress GZ.compress gunzip gzip l ------------------------------------------------------------------------------ testIdCompress :: Test testIdCompress = testProperty "zlib/idCompress" $ monadicIO $ forAllM arbitrary prop where prop :: [ByteString] -> PropertyM IO () prop l = propId "idCompress" Z.decompress Z.compress decompress compress l ------------------------------------------------------------------------------ propId :: String -> (L.ByteString -> L.ByteString) -> (L.ByteString -> L.ByteString) -> (InputStream ByteString -> IO (InputStream ByteString)) -> (CompressionLevel -> OutputStream ByteString -> IO (OutputStream ByteString)) -> [ByteString] -> PropertyM IO () propId name inf def infStr defStr l0 = do pre (not (null l0) && L.length (L.fromChunks l0) > 0) liftQ $ do let l = L.fromChunks $ l0 ++ [ S.concat $ L.toChunks $ L.take 32000 $ L.fromChunks $ cycle l0 ] let inp = def l is <- fromList (L.toChunks inp) >>= infStr (os0, grab) <- listOutputStream os <- defStr defaultCompressionLevel os0 connect is os outp <- liftM L.fromChunks grab assertEqual name l (inf outp) ------------------------------------------------------------------------------ testBigString :: Test testBigString = testCase "zlib/bigString" $ do let l = S.concat $ L.toChunks $ L.take 640000 $ L.fromChunks $ cycle [ "lfkdsjflkdshflkjdhsfkljhdslkfhdslakjfhlkdsjhflkjdsahflkjhsa" , "39287647893264987368947632198746328974698327649873216498713" , "bznmbxz879hJKHYG^&%^&^%*&^%*&^%*&^%&*^%&*65tykjhdgbmdnvkjch" , "VBUYDUHKJC*(HJKDHLCJBUYEOUIHJCHUOY&*^(*)@HJDNM>= connectTo os out <- liftM L.fromChunks grab let o1 = L.fromChunks [l] let o2 = GZ.decompress out when (o1 /= o2) $ do putStrLn "o1 /= o2" putStrLn $ "o1 = " ++ (show $ S.concat $ L.toChunks $ L.take 1000 o1) ++ "..." putStrLn $ "o2 = " ++ (show $ S.concat $ L.toChunks $ L.take 1000 o2) ++ "..." putStrLn $ "len(o1)=" ++ show (L.length o1) putStrLn $ "len(o2)=" ++ show (L.length o2) assertBool "bigString1" $ o1 == o2 is2 <- fromList ([""] ++ L.toChunks out ++ [""]) >>= gunzip (os1, grab') <- listOutputStream connect is2 os1 out' <- liftM L.fromChunks grab' assertBool "bigString2" $ o1 == out' ------------------------------------------------------------------------------ testBuilderFlushGZip :: Test testBuilderFlushGZip = testProperty "zlib/builderFlushGZip" $ monadicIO $ forAllM arbitrary prop where prop :: (ByteString, ByteString) -> PropertyM IO () prop (a,b) = propBuilderFlush "gzip" GZ.decompress gzipBuilder a b ------------------------------------------------------------------------------ testBuilderFlushCompress :: Test testBuilderFlushCompress = testProperty "zlib/builderFlushCompress" $ monadicIO $ forAllM arbitrary prop where prop :: (ByteString, ByteString) -> PropertyM IO () prop (a,b) = propBuilderFlush "zlib" Z.decompress compressBuilder a b ------------------------------------------------------------------------------ propBuilderFlush :: String -> (L.ByteString -> L.ByteString) -> (CompressionLevel -> OutputStream Builder -> IO (OutputStream Builder)) -> ByteString -> ByteString -> PropertyM IO () propBuilderFlush name inf comp a b = do pre (not (S.null a) && not (S.null b)) liftQ $ do t 7 [ byteString a, flush, flush, byteString b , flush, flush ] t 4 [ byteString a, flush, flush, byteString 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 io-streams-1.5.1.0/test/System/IO/Streams/Tests/ByteString.hs0000644000000000000000000005226113423613322022052 0ustar0000000000000000{-# 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.Maybe (isJust) import Data.Monoid import Prelude hiding (lines, read, take, takeWhile, unlines, unwords, words) import qualified Prelude import System.IO.Streams hiding (filter, intersperse, mapM_) import System.IO.Streams.Tests.Common import System.Timeout 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 , testTakeBytes4 , testTakeExactly , testTakeExactly2 , testTakeExactly3 , 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 ------------------------------------------------------------------------------ testTakeBytes4 :: Test testTakeBytes4 = testCase "bytestring/takeBytes4" $ do is <- makeInputStream (threadDelay 20000000 >> return Nothing) >>= takeBytes 0 mb <- timeout 100000 $ toList is assertBool "takeBytes4" $ isJust mb ------------------------------------------------------------------------------ testTakeExactly :: Test testTakeExactly = testProperty "bytestring/takeExactly" $ 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' <- takeExactly 4 is x <- liftM L.fromChunks $ toList is' y <- liftM L.fromChunks $ toList is assertEqual "take1" a x assertEqual "take2" b y ) ------------------------------------------------------------------------------ testTakeExactly2 :: Test testTakeExactly2 = testProperty "bytestring/takeExactly2" $ monadicIO $ forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop l = pre (L.length l < 10) >> liftQ (do is <- fromList (L.toChunks l) is' <- takeExactly 10 is expectExceptionH $ toList is' ) ------------------------------------------------------------------------------ testTakeExactly3 :: Test testTakeExactly3 = testCase "bytestring/takeExactly3" $ do is <- fromList ["one", "two"] is' <- takeExactly 7 is expectExceptionH $ toList is' ------------------------------------------------------------------------------ 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' ------------------------------------------------------------------------------ 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 ["a\nb\nc\n"] >>= lines >>= toList >>= assertEqual "ending in delimiter" ["a","b","c"] 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 "" io-streams-1.5.1.0/test/System/IO/Streams/Tests/Internal.hs0000644000000000000000000001205513423613322021531 0ustar0000000000000000{-# 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 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 import System.IO.Streams.Tests.Common tests :: [Test] tests = [ testAppendInput , testConst , testCoverLockingStream , testPeek , testNullInput , testGenerator , testGeneratorInstances , testConsumer , testTrivials ] ------------------------------------------------------------------------------ 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 ------------------------------------------------------------------------------ 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) ------------------------------------------------------------------------------ testTrivials :: Test testTrivials = testCase "internal/trivials" $ do coverTypeableInstance (undefined :: InputStream Int) coverTypeableInstance (undefined :: OutputStream Int) coverTypeableInstance (undefined :: Generator Int ()) coverTypeableInstance (undefined :: Consumer Int ()) coverTypeableInstance (undefined :: SP Int Int) io-streams-1.5.1.0/test/System/IO/Streams/Tests/Process.hs0000644000000000000000000000611413423613322021372 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module System.IO.Streams.Tests.Process (tests) where ------------------------------------------------------------------------------ import Control.Concurrent import Control.Exception import Control.Monad (liftM, void) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified System.IO.Streams as Streams import System.Timeout import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) ------------------------------------------------------------------------------ tests :: [Test] #ifndef ENABLE_PROCESS_TESTS tests = [] #else tests = [ testInteractiveCommand , testInteractiveProcess ] ------------------------------------------------------------------------------ testInteractiveCommand :: Test testInteractiveCommand = testCase "process/interactiveCommand" $ do (out, err) <- Streams.runInteractiveCommand "cat" >>= run [expected] assertEqual "interactiveCommand" expected out assertEqual "interactiveCommand" "" err where expected = "testing 1-2-3" ------------------------------------------------------------------------------ testInteractiveProcess :: Test testInteractiveProcess = testCase "process/interactiveProcess" $ do (out, err) <- Streams.runInteractiveProcess "tr" ["a-z", "A-Z"] Nothing Nothing >>= run [inputdata] assertEqual "interactiveProcess" expected out assertEqual "interactiveProcess" "" err where inputdata = "testing 1-2-3" expected = "TESTING 1-2-3" ------------------------------------------------------------------------------ run :: [ByteString] -> (Streams.OutputStream ByteString, Streams.InputStream S.ByteString, Streams.InputStream S.ByteString, Streams.ProcessHandle) -> IO (S.ByteString, S.ByteString) run input (stdin, stdout, stderr, processHandle) = tout 5000000 $ do me <- myThreadId outM <- newEmptyMVar errM <- newEmptyMVar bracket (mkThreads me outM errM) killThreads $ go outM errM where tout t m = timeout t m >>= maybe (error "timeout") return barfTo me (e :: SomeException) = throwTo me e killMe restore me m = void (try (restore m) >>= either (barfTo me) return) mkThreads me outM errM = mask $ \restore -> do tid1 <- forkIO $ killMe restore me $ snarf stdout outM tid2 <- forkIO $ killMe restore me $ snarf stderr errM return (tid1, tid2) killThreads (t1, t2) = do mapM_ killThread [t1, t2] Streams.waitForProcess processHandle go outM errM _ = do Streams.fromList input >>= Streams.connectTo stdin out <- takeMVar outM err <- takeMVar errM return (out, err) snarf is mv = liftM S.concat (Streams.toList is) >>= putMVar mv -- ENABLE_PROCESS_TESTS #endif io-streams-1.5.1.0/test/System/IO/Streams/Tests/List.hs0000644000000000000000000000523613423613322020673 0ustar0000000000000000{-# 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, testChunkWithJoin ] 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] testChunkWithJoin :: Test testChunkWithJoin = testCase "list/chunkListWith and join" $ do fromList [1..10 :: Int] >>= chunkListWith (\_ n -> n>=3) >>= toList >>= assertEqual "chunkListWith" [ [1,2,3] , [4,5,6] , [7,8,9] , [10] ] fromList [1..12 :: Int] >>= chunkListWith (\_ n -> n>=3) >>= concatLists >>= toList >>= assertEqual "concatlists" [1..12] fromList ['a'..'z' :: Char] >>= chunkListWith (\x n -> n>=4 && x `elem` ("aeiouy" :: String)) >>= toList >>= assertEqual "chunkListWith" [ "abcde" , "fghi" , "jklmno" , "pqrstu" , "vwxy" , "z" ] io-streams-1.5.1.0/test/System/IO/Streams/Tests/Builder.hs0000644000000000000000000001144413423613322021344 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module System.IO.Streams.Tests.Builder (tests) where ------------------------------------------------------------------------------ import Control.Monad import Data.ByteString.Builder (byteString, toLazyByteString) import Data.ByteString.Builder.Extra (flush) import Data.ByteString.Builder.Internal (newBuffer) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.List import Data.Monoid import System.IO.Streams hiding (intersperse, map, take) import qualified System.IO.Streams as Streams import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) ------------------------------------------------------------------------------ tests :: [Test] tests = [ testBuilderStream , testRepeatedConnects , 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 byteString l1 ++ [flush] ++ map byteString 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 ------------------------------------------------------------------------------ testRepeatedConnects :: Test testRepeatedConnects = testCase "builder/repeatedConnects" $ do (os0, grab) <- Streams.listOutputStream os <- Streams.builderStream os0 is0 <- Streams.fromList ["Hello, world!\n"] >>= Streams.map byteString is1 <- Streams.fromList ["Bye, world!\n"] >>= Streams.map byteString Streams.connect is0 os Streams.connect is1 os Streams.write Nothing os grab >>= assertEqual "repeated connect" ["Hello, world!\n"] ------------------------------------------------------------------------------ testUnsafeBuilderStream :: Test testUnsafeBuilderStream = testCase "builder/unsafeBuilderStream" $ do let l1 = intersperse " " ["the", "quick", "brown", "fox"] let l2 = intersperse " " ["jumped", "over", "the"] let l = map byteString l1 ++ [flush] ++ map byteString l2 is <- fromList l (os0, grab) <- listOutputStream os1 <- contramapM (return . S.copy) os0 os <- unsafeBuilderStream (newBuffer 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 <- builderStreamWithBufferSize 10 os0 let l1 = intersperse " " ["the", "quick", "brown"] let l2 = [" fooooooooooooooooox"] let l = map byteString l1 ++ [flush, flush, flush] ++ map byteString 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 (newBuffer 10) os1 let l = take 3000 $ cycle $ replicate 20 (byteString "bloooooooort") ++ [flush] is <- fromList l let s = S.concat $ L.toChunks $ toLazyByteString $ mconcat l connect is os output <- liftM S.concat grab assertEqual "short buffer 2" s output write (Just $ byteString "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 io-streams-1.5.1.0/test/System/IO/Streams/Tests/Concurrent.hs0000644000000000000000000000653513423613322022105 0ustar0000000000000000module System.IO.Streams.Tests.Concurrent (tests) where ------------------------------------------------------------------------------ import Control.Concurrent import Control.Monad import Prelude hiding (lines, read, takeWhile, unlines, unwords, unwords, words) import qualified System.IO.Streams as Streams import qualified System.IO.Streams.Concurrent as Streams 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 = [ testMakeChanPipe , testConcurrentMerge , testConcurrentMergeException , testInputOutput ] ------------------------------------------------------------------------------ testMakeChanPipe :: Test testMakeChanPipe = testProperty "concurrent/makeChanPipe" $ monadicIO $ forAllM arbitrary prop where prop :: [Int] -> PropertyM IO () prop l = liftQ $ do (is, os) <- Streams.makeChanPipe _ <- forkIO $ Streams.writeList l os >> Streams.write Nothing os Streams.toList is >>= assertEqual "makeChanPipe" l ------------------------------------------------------------------------------ testConcurrentMerge :: Test testConcurrentMerge = testCase "concurrent/concurrentMerge" $ do mvars <- replicateM nthreads newEmptyMVar chans <- replicateM nthreads newChan let firstMVar = head mvars mapM_ (forkIO . ring) $ zip3 mvars (take nthreads $ drop 1 $ cycle mvars) chans inputs <- mapM Streams.chanToInput chans resultMVar <- newEmptyMVar _ <- forkIO (Streams.concurrentMerge inputs >>= Streams.toList >>= putMVar resultMVar) putMVar firstMVar 0 result <- takeMVar resultMVar assertEqual "concurrent merge" [0..10] result where maxval = 10 :: Int nthreads = 4 :: Int ring (prev, next, chan) = loop where loop = do x <- takeMVar prev if x > maxval then do writeChan chan Nothing putMVar next x else do writeChan chan $ Just x threadDelay 100000 putMVar next $! x + 1 loop ------------------------------------------------------------------------------ testConcurrentMergeException :: Test testConcurrentMergeException = testCase "concurrent/concurrentMerge/exception" $ do inp <- Streams.makeInputStream (error "bad") >>= Streams.concurrentMerge . (:[]) expectExceptionH (Streams.toList inp) ------------------------------------------------------------------------------ testInputOutput :: Test testInputOutput = testCase "concurrent/input-output" $ do is <- Streams.fromList [1..10::Int] chan <- newChan is' <- Streams.chanToInput chan Streams.inputToChan is chan Streams.toList is' >>= assertEqual "input-output" [1..10] io-streams-1.5.1.0/test/System/IO/Streams/Tests/Attoparsec/0000755000000000000000000000000013423613322021523 5ustar0000000000000000io-streams-1.5.1.0/test/System/IO/Streams/Tests/Attoparsec/Text.hs0000644000000000000000000001142013423613322023001 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module System.IO.Streams.Tests.Attoparsec.Text (tests, testParserU) where ------------------------------------------------------------------------------ import Control.Monad import Data.Attoparsec.Text hiding (eitherResult) import Data.Char (isAlpha, isSpace) import Data.Text (Text) import Prelude hiding (takeWhile) import System.IO.Streams import System.IO.Streams.Attoparsec.Text import System.IO.Streams.Internal.Attoparsec (eitherResult, parseFromStreamInternal) 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 , testParseFromStreamU ] ------------------------------------------------------------------------------ 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 Text) testParser2 = do end <- atEnd if end then return Nothing else liftM Just $ string "bork" ------------------------------------------------------------------------------ testParserU :: Parser (Maybe Text) testParserU = do end <- atEnd if end then return Nothing else do _ <- takeWhile (not . isAlpha) liftM Just (takeWhile isAlpha) ------------------------------------------------------------------------------ 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 "foo") "bar") >=> 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) let (Right x) = eitherResult $ Done undefined 4 :: Either (Text, [String], String) Int assertEqual "eitherResult" 4 x ------------------------------------------------------------------------------ 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 ------------------------------------------------------------------------------ testParseFromStreamU :: Test testParseFromStreamU = testCase "attoparsec/parseFromStreamU" $ do is <- fromList ["123æø", "å", "💻⛇⛄☃Š", "š5ŧđ6naå7"] x0 <- parseFromStream testParserU is assertEqual "first parse" (Just "æøå") x0 l <- parserToInputStream testParserU is >>= toList assertEqual "rest" ["Šš", "ŧđ", "naå", ""] l toList is >>= assertEqual "double eof" [] io-streams-1.5.1.0/test/System/IO/Streams/Tests/Attoparsec/ByteString.hs0000644000000000000000000000766413423613322024166 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module System.IO.Streams.Tests.Attoparsec.ByteString (tests) where ------------------------------------------------------------------------------ import Control.Monad import Data.Attoparsec.ByteString.Char8 hiding (eitherResult) import Data.ByteString.Char8 (ByteString) import Prelude hiding (takeWhile) import System.IO.Streams import System.IO.Streams.Attoparsec.ByteString import System.IO.Streams.Internal.Attoparsec (eitherResult, parseFromStreamInternal) 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 "foo") "bar") >=> 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) let (Right x) = eitherResult $ Done undefined 4 :: Either (ByteString, [String], String) Int assertEqual "eitherResult" 4 x ------------------------------------------------------------------------------ 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 io-streams-1.5.1.0/src/0000755000000000000000000000000013423613322012713 5ustar0000000000000000io-streams-1.5.1.0/src/System/0000755000000000000000000000000013423613322014177 5ustar0000000000000000io-streams-1.5.1.0/src/System/IO/0000755000000000000000000000000013423613322014506 5ustar0000000000000000io-streams-1.5.1.0/src/System/IO/Streams.hs0000644000000000000000000001040613423613322016461 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -- | This module is a top-level convenience module which re-exports most of the -- @io-streams@ library. -- -- It is recommended to import this module qualified, as follows: -- -- @ -- import "System.IO.Streams" ('Generator', 'InputStream', 'OutputStream') -- import qualified "System.IO.Streams" as Streams -- @ -- -- For an in-depth tutorial on how to use @io-streams@, please see the -- "System.IO.Streams.Tutorial" module. -- -- Is there a function missing from this library? Interested in contributing? -- Send a pull request to . module System.IO.Streams ( -- * Stream types InputStream , OutputStream -- ** A note about resource acquisition\/release semantics -- $resource -- * Creating streams , makeInputStream , makeOutputStream -- * Primitive stream operations , read , unRead , peek , write , writeTo , 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.Process , 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.Process 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. -- io-streams-1.5.1.0/src/System/IO/Streams/0000755000000000000000000000000013423613322016124 5ustar0000000000000000io-streams-1.5.1.0/src/System/IO/Streams/Handle.hs0000644000000000000000000001440213423613322017654 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif -- | Input and output streams for file 'Handle's. module System.IO.Streams.Handle ( -- * Handle conversions handleToInputStream , handleToOutputStream , handleToStreams , inputStreamToHandle , outputStreamToHandle , streamPairToHandle -- * Standard system handles , stdin , stdout , stderr ) where ------------------------------------------------------------------------------ import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified GHC.IO.Handle as H import System.IO (Handle, hFlush) import qualified System.IO as IO import System.IO.Unsafe (unsafePerformIO) ------------------------------------------------------------------------------ import System.IO.Streams.Internal (InputStream, OutputStream, SP (..), lockingInputStream, lockingOutputStream, makeInputStream, makeOutputStream) ------------------------------------------------------------------------------ bUFSIZ :: Int bUFSIZ = 32752 ------------------------------------------------------------------------------ -- | Converts a read-only handle into an 'InputStream' of strict 'ByteString's. -- -- Note that the wrapped handle is /not/ closed when it yields end-of-stream; -- you can use 'System.IO.Streams.Combinators.atEndOfInput' to close the handle -- if you would like this behaviour. 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. -- -- Note that the wrapped handle is /not/ closed when it receives end-of-stream; -- you can use 'System.IO.Streams.Combinators.atEndOfOutput' to close the -- handle if you would like this behaviour. -- -- /Note/: to force the 'Handle' to be flushed, you can write a null string to -- the returned 'OutputStream': -- -- > Streams.write (Just "") os handleToOutputStream :: Handle -> IO (OutputStream ByteString) handleToOutputStream h = makeOutputStream f where f Nothing = hFlush h f (Just x) = if S.null x then hFlush h else S.hPut h x ------------------------------------------------------------------------------ -- | Converts a readable and writable handle into an 'InputStream'/'OutputStream' -- of strict 'ByteString's. -- -- Note that the wrapped handle is /not/ closed when it receives -- end-of-stream; you can use -- 'System.IO.Streams.Combinators.atEndOfOutput' to close the handle -- if you would like this behaviour. -- -- /Note/: to force the 'Handle' to be flushed, you can write a null string to -- the returned 'OutputStream': -- -- > Streams.write (Just "") os -- -- /Since: 1.3.4.0./ handleToStreams :: Handle -> IO (InputStream ByteString, OutputStream ByteString) handleToStreams h = do is <- handleToInputStream h os <- handleToOutputStream h return $! (is, os) ------------------------------------------------------------------------------ -- | Converts an 'InputStream' over bytestrings to a read-only 'Handle'. Note -- that the generated handle is opened unbuffered in binary mode (i.e. no -- newline translation is performed). -- -- Note: the 'InputStream' passed into this function is wrapped in -- 'lockingInputStream' to make it thread-safe. -- -- /Since: 1.0.2.0./ inputStreamToHandle :: InputStream ByteString -> IO Handle inputStreamToHandle is0 = do is <- lockingInputStream is0 h <- H.mkDuplexHandle is "*input-stream*" Nothing $! H.noNewlineTranslation H.hSetBuffering h H.NoBuffering return h ------------------------------------------------------------------------------ -- | Converts an 'OutputStream' over bytestrings to a write-only 'Handle'. Note -- that the 'Handle' will be opened in non-buffering mode; if you buffer the -- 'OutputStream' using the 'Handle' buffering then @io-streams@ will copy the -- 'Handle' buffer when sending 'ByteString' values to the output, which might -- not be what you want. -- -- When the output buffer, if used, is flushed (using 'System.IO.hFlush'), an -- empty string is written to the provided 'OutputStream'. -- -- /Note/: the 'OutputStream' passed into this function is wrapped in -- 'lockingOutputStream' to make it thread-safe. -- -- /Since: 1.0.2.0./ outputStreamToHandle :: OutputStream ByteString -> IO Handle outputStreamToHandle os0 = do os <- lockingOutputStream os0 h <- H.mkDuplexHandle os "*output-stream*" Nothing $! H.noNewlineTranslation H.hSetBuffering h H.NoBuffering return $! h ------------------------------------------------------------------------------ -- | Converts a pair of 'InputStream' and 'OutputStream' over bytestrings to a -- read-write 'Handle'. -- -- Note: the streams passed into this function are wrapped in -- locking primitives to make them thread-safe. -- -- /Since: 1.0.2.0./ streamPairToHandle :: InputStream ByteString -> OutputStream ByteString -> IO Handle streamPairToHandle is0 os0 = do is <- lockingInputStream is0 os <- lockingOutputStream os0 h <- H.mkDuplexHandle (SP is os) "*stream*" Nothing $! H.noNewlineTranslation H.hSetBuffering h H.NoBuffering return $! h ------------------------------------------------------------------------------ -- | 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 #-} io-streams-1.5.1.0/src/System/IO/Streams/Text.hs0000644000000000000000000001324713423613322017413 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -- | 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 #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mappend) #endif 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 #-} io-streams-1.5.1.0/src/System/IO/Streams/Vector.hs0000644000000000000000000003055113423613322017726 0ustar0000000000000000{-# 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, fromGenerator, 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 <- S.fromConsumer $ consumer r return (c, flush r) where consumer r = go where go = S.await >>= (maybe (return $! ()) $ \c -> do liftIO $ modifyMVar_ r $ flip vfAppend c go) flush r = modifyMVar r $ \vfi -> do !v <- vfFinish vfi vfi' <- vfNew initialSize return $! (vfi', v) {-# INLINE mutableVectorOutputStreamSized #-} ------------------------------------------------------------------------------ -- | 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 io-streams-1.5.1.0/src/System/IO/Streams/Attoparsec.hs0000644000000000000000000000071613423613322020571 0ustar0000000000000000-- | This module is deprecated -- use -- System.IO.Streams.Attoparsec.ByteString instead (this module simply -- re-exports that one). module System.IO.Streams.Attoparsec ( -- * Parsing parseFromStream , parserToInputStream , ParseException(..) ) where ------------------------------------------------------------------------------ import System.IO.Streams.Attoparsec.ByteString (ParseException (..), parseFromStream, parserToInputStream) io-streams-1.5.1.0/src/System/IO/Streams/Debug.hs0000644000000000000000000000771213423613322017515 0ustar0000000000000000{-# 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 = return $ InputStream produce pb where produce = do m <- Streams.read inputStream Streams.write (Just $! describe m) debugStream return m pb c = do let s = S.concat [name, ": pushback: ", toBS c, "\n"] Streams.write (Just s) debugStream Streams.unRead c inputStream 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 io-streams-1.5.1.0/src/System/IO/Streams/Combinators.hs0000644000000000000000000006773513423613322020762 0ustar0000000000000000-- | Generic stream manipulations {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-} module System.IO.Streams.Combinators ( -- * Folds inputFoldM , outputFoldM , fold , foldM , fold_ , foldM_ , any , all , maximum , minimum -- * Unfolds , unfoldM -- * Maps , map , mapM , mapM_ , mapMaybe , contramap , contramapM , contramapM_ , contramapMaybe -- * Filter , filter , filterM , filterOutput , filterOutputM -- * Takes and drops , give , take , drop , ignore -- * Zip and unzip , zip , zipWith , zipWithM , unzip -- * Utility , intersperse , skipToEof , ignoreEof , atEndOfInput , atEndOfOutput ) 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 (IORef, atomicModifyIORef, modifyIORef, newIORef, readIORef, writeIORef) import Data.Maybe (isJust) import Prelude hiding (all, any, drop, filter, map, mapM, mapM_, maximum, minimum, read, take, unzip, zip, zipWith) ------------------------------------------------------------------------------ import System.IO.Streams.Internal (InputStream (..), OutputStream (..), fromGenerator, makeInputStream, makeOutputStream, read, 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 and reset 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 and reset 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 and reset 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 and reset 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) ------------------------------------------------------------------------------ -- | A variant of 'System.IO.Streams.fold' suitable for use with composable folds -- from \'beautiful folding\' libraries like -- . -- The input stream is fully consumed. -- -- Example: -- -- @ -- ghci> let folds = liftA3 (,,) Foldl.length Foldl.mean Foldl.maximum -- ghci> Streams.'System.IO.Streams.fromList' [1..10::Double] >>= Foldl.purely Streams.'System.IO.Streams.fold_' folds is -- ghci> (10,5.5,Just 10.0) -- @ -- -- /Since 1.3.6.0/ -- fold_ :: (x -> a -> x) -- ^ accumulator update function -> x -- ^ initial seed -> (x -> s) -- ^ recover folded value -> InputStream a -- ^ input stream -> IO s fold_ op seed done stream = liftM done (go seed) where go !s = read stream >>= maybe (return s) (go . op s) ------------------------------------------------------------------------------ -- | A variant of 'System.IO.Streams.foldM' suitable for use with composable folds -- from \'beautiful folding\' libraries like -- . -- The input stream is fully consumed. -- -- Example: -- -- @ -- ghci> let folds = Foldl.mapM_ print *> Foldl.generalize (liftA2 (,) Foldl.sum Foldl.mean) -- ghci> Streams.'System.IO.Streams.fromList' [1..3::Double] >>= Foldl.impurely Streams.'System.IO.Streams.foldM_' folds -- 1.0 -- 2.0 -- 3.0 -- (6.0,2.0) -- @ -- -- /Since 1.3.6.0/ -- foldM_ :: (x -> a -> IO x) -- ^ accumulator update action -> IO x -- ^ initial seed -> (x -> IO s) -- ^ recover folded value -> InputStream a -- ^ input stream -> IO s foldM_ f seed done stream = seed >>= go where go !x = read stream >>= maybe (done x) ((go =<<) . f x) ------------------------------------------------------------------------------ -- | @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 ------------------------------------------------------------------------------ -- | A version of map that discards elements -- -- @mapMaybe f s@ passes all output from @s@ through the function @f@ and -- discards elements for which @f s@ evaluates to 'Nothing'. -- -- Example: -- -- @ -- ghci> Streams.'System.IO.Streams.fromList' [Just 1, None, Just 3] >>= -- Streams.'mapMaybe' 'id' >>= -- Streams.'System.IO.Streams.toList' -- [1,3] -- @ -- -- /Since: 1.2.1.0/ mapMaybe :: (a -> Maybe b) -> InputStream a -> IO (InputStream b) mapMaybe f src = makeInputStream g where g = do s <- read src case s of Nothing -> return Nothing Just x -> case f x of Nothing -> g y -> return y ------------------------------------------------------------------------------ -- | 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 ------------------------------------------------------------------------------ -- | Contravariant counterpart to 'contramapMaybe'. -- -- @contramap f s@ passes all input to @s@ through the function @f@. -- Discards all the elements for which @f@ returns 'Nothing'. -- -- /Since: 1.2.1.0/ -- contramapMaybe :: (a -> Maybe b) -> OutputStream b -> IO (OutputStream a) contramapMaybe f s = makeOutputStream $ g where g Nothing = write Nothing s g (Just a) = case f a of Nothing -> return () x -> write x 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 = return $! InputStream prod pb where prod = read src >>= maybe eof chunk chunk s = do b <- p s if b then return $! Just s else prod eof = return Nothing pb s = unRead s src ------------------------------------------------------------------------------ -- | 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 = return $! InputStream prod pb where prod = read src >>= maybe eof chunk chunk s = do let b = p s if b then return $! Just s else prod eof = return Nothing pb s = unRead s src ------------------------------------------------------------------------------ -- | The function @intersperse v s@ wraps the 'OutputStream' @s@, creating a -- new output stream that writes its input to @s@ interspersed with the -- provided value @v@. See 'Data.List.intersperse'. -- -- Example: -- -- @ -- ghci> import Control.Monad ((>=>)) -- ghci> is <- Streams.'System.IO.Streams.List.fromList' [\"nom\", \"nom\", \"nom\"::'ByteString'] -- ghci> Streams.'System.IO.Streams.List.outputToList' (Streams.'intersperse' \"burp!\" >=> Streams.'System.IO.Streams.connect' is) -- [\"nom\",\"burp!\",\"nom\",\"burp!\",\"nom\"] -- @ intersperse :: a -> OutputStream a -> IO (OutputStream a) intersperse sep os = newIORef False >>= makeOutputStream . f where f _ Nothing = write Nothing os f sendRef s = do b <- readIORef sendRef writeIORef sendRef True when b $ write (Just sep) os write s os ------------------------------------------------------------------------------ -- | Combines two input streams. Continues yielding elements from both input -- streams until one of them finishes. zip :: InputStream a -> InputStream b -> IO (InputStream (a, b)) zip src1 src2 = makeInputStream src where src = read src1 >>= (maybe (return Nothing) $ \a -> read src2 >>= (maybe (unRead a src1 >> return Nothing) $ \b -> return $! Just $! (a, b))) ------------------------------------------------------------------------------ -- | Combines two input streams using the supplied function. Continues yielding -- elements from both input streams until one of them finishes. zipWith :: (a -> b -> c) -> InputStream a -> InputStream b -> IO (InputStream c) zipWith f src1 src2 = makeInputStream src where src = read src1 >>= (maybe (return Nothing) $ \a -> read src2 >>= (maybe (unRead a src1 >> return Nothing) $ \b -> return $! Just $! f a b ) ) ------------------------------------------------------------------------------ -- | Combines two input streams using the supplied monadic function. Continues -- yielding elements from both input streams until one of them finishes. zipWithM :: (a -> b -> IO c) -> InputStream a -> InputStream b -> IO (InputStream c) zipWithM f src1 src2 = makeInputStream src where src = read src1 >>= (maybe (return Nothing) $ \a -> read src2 >>= (maybe (unRead a src1 >> return Nothing) $ \b -> f a b >>= \c -> return $! Just $! c ) ) ------------------------------------------------------------------------------ -- | Filters output to be sent to the given 'OutputStream' using a pure -- function. See 'filter'. -- -- Example: -- -- @ -- ghci> import qualified "Data.ByteString.Char8" as S -- ghci> os1 \<- Streams.'System.IO.Streams.stdout' >>= Streams.'System.IO.Streams.unlines -- ghci> os2 \<- os1 >>= Streams.'contramap' (S.pack . show) >>= Streams.'filterOutput' even -- ghci> Streams.'write' (Just 3) os2 -- ghci> Streams.'write' (Just 4) os2 -- 4 -- @ {- Note: The example is a lie, because unlines has weird behavior -} filterOutput :: (a -> Bool) -> OutputStream a -> IO (OutputStream a) filterOutput p output = makeOutputStream chunk where chunk Nothing = write Nothing output chunk ch@(Just x) = when (p x) $ write ch output ------------------------------------------------------------------------------ -- | Filters output to be sent to the given 'OutputStream' using a predicate -- function in IO. See 'filterM'. -- -- Example: -- -- @ -- ghci> let check a = putStrLn a ("Allow " ++ show a ++ "?") >> readLn :: IO Bool -- ghci> import qualified Data.ByteString.Char8 as S -- ghci> os1 <- Streams.'System.IO.Streams.unlines' Streams.'System.IO.Streams.stdout' -- ghci> os2 \<- os1 >>= Streams.'contramap' (S.pack . show) >>= Streams.'filterOutputM' check -- ghci> Streams.'System.IO.Streams.write' (Just 3) os2 -- Allow 3? -- False\ -- ghci> Streams.'System.IO.Streams.write' (Just 4) os2 -- Allow 4? -- True\ -- 4 -- @ filterOutputM :: (a -> IO Bool) -> OutputStream a -> IO (OutputStream a) filterOutputM p output = makeOutputStream chunk where chunk Nothing = write Nothing output chunk ch@(Just x) = do b <- p x if b then write ch output else return $! () ------------------------------------------------------------------------------ -- | Takes apart a stream of pairs, producing a pair of input streams. Reading -- from either of the produced streams will cause a pair of values to be pulled -- from the original stream if necessary. Note that reading @n@ values from one -- of the returned streams will cause @n@ values to be buffered at the other -- stream. -- -- Access to the original stream is thread safe, i.e. guarded by a lock. unzip :: forall a b . InputStream (a, b) -> IO (InputStream a, InputStream b) unzip os = do lock <- newMVar $! () buf1 <- newIORef id buf2 <- newIORef id is1 <- makeInputStream $ src1 lock buf1 buf2 is2 <- makeInputStream $ src2 lock buf1 buf2 return (is1, is2) where twist (a,b) = (b,a) src1 lock aBuf bBuf = withMVar lock $ const $ do dl <- readIORef aBuf case dl [] of [] -> more os id bBuf (x:xs) -> writeIORef aBuf (xs++) >> (return $! Just x) src2 lock aBuf bBuf = withMVar lock $ const $ do dl <- readIORef bBuf case dl [] of [] -> more os twist aBuf (y:ys) -> writeIORef bBuf (ys++) >> (return $! Just y) more :: forall a b x y . InputStream (a,b) -> ((a,b) -> (x,y)) -> IORef ([y] -> [y]) -> IO (Maybe x) more origs proj buf = read origs >>= maybe (return Nothing) (\x -> do let (a, b) = proj x modifyIORef buf (. (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 = do kref <- newIORef k0 return $! InputStream (prod kref) (pb kref) where prod kref = do !k <- readIORef kref if k <= 0 then return Nothing else do m <- read input when (isJust m) $ modifyIORef kref $ \x -> x - 1 return m pb kref !s = do unRead s input modifyIORef kref (+1) ------------------------------------------------------------------------------ -- | 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 = do kref <- newIORef k0 return $! InputStream (prod kref) (pb kref) where prod kref = do !k <- readIORef kref if k <= 0 then getInput kref else discard kref getInput kref = do read input >>= maybe (return Nothing) (\c -> do modifyIORef kref (\x -> x - 1) return $! Just c) discard kref = getInput kref >>= maybe (return Nothing) (const $ prod kref) pb kref s = do unRead s input modifyIORef kref (+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 ------------------------------------------------------------------------------ -- | Wraps an 'OutputStream', ignoring any end-of-stream 'Nothing' values -- written to the returned stream. -- -- /Since: 1.0.1.0/ -- ignoreEof :: OutputStream a -> IO (OutputStream a) ignoreEof s = return $ OutputStream f where f Nothing = return $! () f x = write x s ------------------------------------------------------------------------------ -- | Wraps an 'InputStream', running the specified action when the stream -- yields end-of-file. -- -- /Since: 1.0.2.0/ -- atEndOfInput :: IO b -> InputStream a -> IO (InputStream a) atEndOfInput m is = return $! InputStream prod pb where prod = read is >>= maybe eof (return . Just) eof = void m >> return Nothing pb s = unRead s is ------------------------------------------------------------------------------ -- | Wraps an 'OutputStream', running the specified action when the stream -- receives end-of-file. -- -- /Since: 1.0.2.0/ -- atEndOfOutput :: IO b -> OutputStream a -> IO (OutputStream a) atEndOfOutput m os = makeOutputStream f where f Nothing = write Nothing os >> void m f x = write x os io-streams-1.5.1.0/src/System/IO/Streams/Network.hs0000644000000000000000000000056713423613322020121 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Converting network 'Socket's to streams. module System.IO.Streams.Network ( -- * Sockets to Streams socketToStreams , socketToStreamsWithBufferSize ) where ------------------------------------------------------------------------------ import System.IO.Streams.Internal.Network (socketToStreams, socketToStreamsWithBufferSize) io-streams-1.5.1.0/src/System/IO/Streams/Tutorial.hs0000644000000000000000000003772613423613322020302 0ustar0000000000000000module 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' inStream3 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 -- @ io-streams-1.5.1.0/src/System/IO/Streams/File.hs0000644000000000000000000001026213423613322017340 0ustar0000000000000000-- | 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 (handleToInputStream, handleToOutputStream) 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 io-streams-1.5.1.0/src/System/IO/Streams/Zlib.hs0000644000000000000000000001612413423613322017364 0ustar0000000000000000-- | 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 Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.IORef (newIORef, readIORef, writeIORef) import Prelude hiding (read) ------------------------------------------------------------------------------ import Codec.Zlib (Deflate, Inflate, Popper, WindowBits (..), feedDeflate, feedInflate, finishDeflate, finishInflate, flushDeflate, flushInflate, initDeflate, initInflate) import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Builder.Extra (defaultChunkSize, flush) import Data.ByteString.Builder.Internal (newBuffer) ------------------------------------------------------------------------------ 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 (newBuffer defaultChunkSize) zippedStr where bytestringStream x = write (fmap cvt x) stream cvt s | S.null s = flush | otherwise = byteString 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 io-streams-1.5.1.0/src/System/IO/Streams/ByteString.hs0000644000000000000000000006346113423613322020564 0ustar0000000000000000{-# 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 , takeExactly , 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, unlines, unwords, words) ------------------------------------------------------------------------------ import System.IO.Streams.Combinators (filterM, intersperse, outputFoldM) import System.IO.Streams.Internal (InputStream (..), OutputStream, makeInputStream, makeOutputStream, read, 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 :: Int64) return $! (InputStream (prod ref) (pb ref), readIORef ref) where prod ref = read src >>= maybe (return Nothing) (\x -> do modifyRef ref (+ (fromIntegral $ S.length x)) return $! Just x) pb ref s = do modifyRef ref (\x -> x - (fromIntegral $ S.length s)) unRead s src ------------------------------------------------------------------------------ -- | 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 = takeBytes' k0 (return Nothing) {-# INLINE takeBytes #-} ------------------------------------------------------------------------------ -- | Like @Streams.'takeBytes'@, but throws 'ReadTooShortException' when -- there aren't enough bytes present on the source. takeExactly :: Int64 -- ^ number of bytes to read -> InputStream ByteString -- ^ input stream to wrap -> IO (InputStream ByteString) takeExactly k0 = takeBytes' k0 (throwIO $ ReadTooShortException k0) {-# INLINE takeExactly #-} ------------------------------------------------------------------------------ -- Helper for the two above. takeBytes' :: Int64 -> IO (Maybe ByteString) -- ^ What to do if the input ends before having consumed the -- right amount of bytes. -> InputStream ByteString -> IO (InputStream ByteString) takeBytes' k0 h src = do kref <- newIORef k0 return $! InputStream (prod kref) (pb kref) where prod kref = do k <- readIORef kref if k <= 0 then return Nothing else read src >>= maybe h (chunk k) where chunk k s = do let l = fromIntegral $ S.length s let k' = k - l if k' <= 0 then let (a,b) = S.splitAt (fromIntegral k) s in do when (not $ S.null b) $ unRead b src writeIORef kref 0 return $! Just a else writeIORef kref k' >> return (Just s) pb kref s = do modifyRef kref (+ (fromIntegral $ S.length s)) unRead s src {-# INLINE takeBytes' #-} ------------------------------------------------------------------------------ -- | 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. -- -- * if the input ends in the delimiter, a final empty string is /not/ -- emitted. (/Since: 1.5.0.0. Previous versions had the opposite behaviour, -- which was changed to match 'Prelude.lines'./) -- -- 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 when (not $ S.null b') $ unRead b' is writeIORef ref id 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' and 'takeExactly' when not enough bytes were -- available on the input. data ReadTooShortException = ReadTooShortException Int64 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 = do kref <- newIORef k0 return $! InputStream (prod kref) (pb kref) where prod kref = read src >>= maybe (return Nothing) chunk where chunk s = do k <- readIORef kref let k' = k - l case () of !_ | l == 0 -> return (Just s) | k == 0 -> throwIO TooManyBytesReadException | k' >= 0 -> writeIORef kref k' >> return (Just s) | otherwise -> do let (!a,!b) = S.splitAt (fromEnum k) s writeIORef kref 0 unRead b src return $! Just a where l = toEnum $ S.length s pb kref s = do unRead s src modifyRef kref (+ (fromIntegral $ S.length 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 (fromIntegral 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 = do kref <- newIORef k0 makeOutputStream $ sink kref where sink _ Nothing = write Nothing str sink kref mb@(Just x) = do k <- readIORef kref let l = fromIntegral $ S.length x let k' = k - l if k' < 0 then do let a = S.take (fromIntegral k) x when (not $ S.null a) $ write (Just a) str writeIORef kref 0 else writeIORef kref k' >> write mb str ------------------------------------------------------------------------------ -- | 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 = do kref <- newIORef k0 makeOutputStream $ sink kref where sink _ Nothing = write Nothing str sink kref mb@(Just x) = do k <- readIORef kref let l = toEnum $ S.length x let k' = k - l if k' < 0 then throwIO TooManyBytesWrittenException else writeIORef kref k' >> write mb str ------------------------------------------------------------------------------ -- | 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 bytesRead <- newIORef (0 :: Int64) return $! InputStream (prod startTime bytesRead) (pb bytesRead) where prod startTime bytesReadRef = read stream >>= maybe (return Nothing) chunk where chunk s = do let slen = S.length s now <- getTime let !delta = now - startTime nb <- readIORef bytesReadRef let newBytes = nb + fromIntegral slen when (delta > minSeconds + 1 && (fromIntegral newBytes / (delta - minSeconds)) < minRate) $ throwIO RateTooSlowException -- otherwise, bump the timeout and return the input !_ <- bump writeIORef bytesReadRef newBytes return $! Just s pb bytesReadRef s = do modifyRef bytesReadRef $ \x -> x - (fromIntegral $ S.length s) unRead s stream minSeconds = fromIntegral minSeconds' io-streams-1.5.1.0/src/System/IO/Streams/Core.hs0000644000000000000000000000160013423613322017345 0ustar0000000000000000{-# 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 , writeTo , atEOF -- * Connecting streams together , connect , connectTo , supply , supplyTo , appendInputStream , concatInputStreams -- * Thread safety \/ concurrency , lockingInputStream , lockingOutputStream -- * Utility streams , nullInput , nullOutput -- * Generator monad , Generator , fromGenerator , yield ) where ------------------------------------------------------------------------------ import Prelude () import System.IO.Streams.Internal io-streams-1.5.1.0/src/System/IO/Streams/Internal.hs0000644000000000000000000005521613423613322020245 0ustar0000000000000000-- | 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 CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} module System.IO.Streams.Internal ( -- * Types SP(..) , StreamPair -- * About pushback -- $pushback -- * Input and output streams , InputStream(..) , OutputStream(..) -- * Primitive stream operations , read , unRead , peek , write , writeTo , atEOF -- * Building streams , makeInputStream , makeOutputStream , appendInputStream , concatInputStreams -- * Connecting streams , connect , connectTo , supply , supplyTo -- * Thread safety , lockingInputStream , lockingOutputStream -- * Utility streams , nullInput , nullOutput -- * Generator monad , Generator , fromGenerator , yield -- * Consumer monad , Consumer , fromConsumer , await ) where ------------------------------------------------------------------------------ #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative (..), (<$>)) #endif import Control.Concurrent (newMVar, withMVar) import Control.Exception (throwIO) import Control.Monad (when) import Control.Monad.IO.Class (MonadIO (..)) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Internal as S import qualified Data.ByteString.Unsafe as S import Data.IORef (newIORef, readIORef, writeIORef) import Data.Maybe (isNothing) import Data.Typeable (Typeable) import Data.Word (Word8) import Foreign.Marshal.Utils (copyBytes) import Foreign.Ptr (castPtr) import qualified GHC.IO.Buffer as H import qualified GHC.IO.BufferedIO as H import qualified GHC.IO.Device as H import GHC.IO.Exception (unsupportedOperation) import Prelude hiding (read) ------------------------------------------------------------------------------ -- | A strict pair type. data SP a b = SP !a !b deriving (Typeable) ------------------------------------------------------------------------------ -- | 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)@ -- data InputStream a = InputStream { _read :: IO (Maybe a) , _unRead :: a -> IO () } deriving (Typeable) ------------------------------------------------------------------------------ -- | 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 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.) -- data OutputStream a = OutputStream { _write :: Maybe a -> IO () } deriving (Typeable) ------------------------------------------------------------------------------ -- | 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 a -> IO (Maybe a) read = _read {-# INLINE read #-} ------------------------------------------------------------------------------ -- | 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 supplying 'Nothing'. -- write :: Maybe a -> OutputStream a -> IO () write = flip _write {-# INLINE write #-} ------------------------------------------------------------------------------ -- | Flipped version of 'write'. -- -- /Since: 1.3.0.0./ writeTo :: OutputStream a -> Maybe a -> IO () writeTo = _write {-# INLINE writeTo #-} ------------------------------------------------------------------------------ -- | 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 a -> IO (Maybe a) peek s = do x <- read s maybe (return $! ()) (_unRead s) x return x ------------------------------------------------------------------------------ -- | 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 :: a -> InputStream a -> IO () unRead = flip _unRead ------------------------------------------------------------------------------ -- | 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 m = do doneRef <- newIORef False pbRef <- newIORef [] return $! InputStream (grab doneRef pbRef) (pb pbRef) where grab doneRef pbRef = do l <- readIORef pbRef case l of [] -> do done <- readIORef doneRef if done then return Nothing else do x <- m when (isNothing x) $ writeIORef doneRef True return x (x:xs) -> writeIORef pbRef xs >> (return $! Just x) pb ref x = readIORef ref >>= \xs -> writeIORef ref (x:xs) {-# INLINE makeInputStream #-} ------------------------------------------------------------------------------ -- | Creates an 'OutputStream' from a value-consuming action. -- -- (@makeOutputStream f@) runs the computation @f@ on each value fed to it. -- -- Since version 1.2.0.0, 'makeOutputStream' also ensures that output streams -- no longer receive data once EOF is received (i.e. you can now assume that -- makeOutputStream will feed your function @Nothing@ at most once.) makeOutputStream :: (Maybe a -> IO ()) -> IO (OutputStream a) makeOutputStream func = (OutputStream . go) <$> newIORef False where go closedRef !m = do closed <- readIORef closedRef if closed then return $! () else do when (isNothing m) $ writeIORef closedRef True func m {-# 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 $! () return $! InputStream (grab mv) (pb mv) where grab mv = withMVar mv $ const $ read s pb mv x = withMVar mv $ const $ unRead x s {-# 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 = makeInputStream $ return Nothing ------------------------------------------------------------------------------ -- | An empty 'OutputStream' that discards any input fed to it. nullOutput :: IO (OutputStream a) nullOutput = makeOutputStream $ const $ return $! () ------------------------------------------------------------------------------ -- | '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] ------------------------------------------------------------------------------ -- | '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 ------------------------------------------------------------------------------ -- | 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) -- @ -------------------------------------------- -- Typeclass instances for Handle support -- -------------------------------------------- ------------------------------------------------------------------------------ bUFSIZ :: Int bUFSIZ = 32752 ------------------------------------------------------------------------------ unsupported :: IO a unsupported = throwIO unsupportedOperation ------------------------------------------------------------------------------ bufferToBS :: H.Buffer Word8 -> ByteString bufferToBS buf = S.copy $! S.fromForeignPtr raw l sz where raw = H.bufRaw buf l = H.bufL buf r = H.bufR buf sz = r - l ------------------------------------------------------------------------------ instance H.RawIO (InputStream ByteString) where read is ptr n = read is >>= maybe (return 0) f where f s = S.unsafeUseAsCStringLen s $ \(cstr, l) -> do let c = min n l copyBytes ptr (castPtr cstr) c return $! c readNonBlocking _ _ _ = unsupported write _ _ _ = unsupported writeNonBlocking _ _ _ = unsupported ------------------------------------------------------------------------------ instance H.RawIO (OutputStream ByteString) where read _ _ _ = unsupported readNonBlocking _ _ _ = unsupported write os ptr n = S.packCStringLen (castPtr ptr, n) >>= flip write os . Just writeNonBlocking _ _ _ = unsupported ------------------------------------------------------------------------------ -- | Internal convenience synonym for a pair of input\/output streams. type StreamPair a = SP (InputStream a) (OutputStream a) instance H.RawIO (StreamPair ByteString) where read (SP is _) ptr n = H.read is ptr n readNonBlocking _ _ _ = unsupported write (SP _ os) ptr n = H.write os ptr n writeNonBlocking _ _ _ = unsupported ------------------------------------------------------------------------------ instance H.BufferedIO (OutputStream ByteString) where newBuffer !_ bs = H.newByteBuffer bUFSIZ bs fillReadBuffer !_ _ = unsupported fillReadBuffer0 !_ _ = unsupported flushWriteBuffer !os !buf = do write (Just $! bufferToBS buf) os emptyWriteBuffer buf flushWriteBuffer0 !os !buf = do let s = bufferToBS buf let l = S.length s write (Just s) os buf' <- emptyWriteBuffer buf return $! (l, buf') ------------------------------------------------------------------------------ instance H.BufferedIO (InputStream ByteString) where newBuffer !_ !bs = H.newByteBuffer bUFSIZ bs fillReadBuffer !is !buf = H.readBuf is buf fillReadBuffer0 _ _ = unsupported flushWriteBuffer _ _ = unsupported flushWriteBuffer0 _ _ = unsupported ------------------------------------------------------------------------------ instance H.BufferedIO (StreamPair ByteString) where newBuffer !_ bs = H.newByteBuffer bUFSIZ bs fillReadBuffer (SP is _) = H.fillReadBuffer is fillReadBuffer0 _ _ = unsupported flushWriteBuffer (SP _ !os) = H.flushWriteBuffer os flushWriteBuffer0 (SP _ !os) = H.flushWriteBuffer0 os ------------------------------------------------------------------------------ instance H.IODevice (OutputStream ByteString) where ready _ _ _ = return True close = write Nothing devType _ = return H.Stream ------------------------------------------------------------------------------ instance H.IODevice (InputStream ByteString) where ready _ _ _ = return True close _ = return $! () devType _ = return H.Stream ------------------------------------------------------------------------------ instance H.IODevice (StreamPair ByteString) where ready _ _ _ = return True close (SP _ os) = write Nothing os devType _ = return H.Stream ------------------------------------------------------------------------------ emptyWriteBuffer :: H.Buffer Word8 -> IO (H.Buffer Word8) emptyWriteBuffer buf = return buf { H.bufL=0, H.bufR=0, H.bufState = H.WriteBuffer } ------------------------------------------------------------------------------ -- | 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) } deriving (Typeable) ------------------------------------------------------------------------------ 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 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) } deriving (Typeable) ------------------------------------------------------------------------------ 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) ------------------------------------------------------------------------------ fromConsumer :: Consumer r a -> IO (OutputStream r) fromConsumer c0 = newIORef c0 >>= makeOutputStream . go where go ref mb = do c <- readIORef ref c' <- unC c >>= either step (const $! return c) writeIORef ref c' where force c = do e <- unC c return $! Consumer $! return e step g = force $! g mb io-streams-1.5.1.0/src/System/IO/Streams/Process.hs0000644000000000000000000000751113423613322020102 0ustar0000000000000000-- | A module adapting the functions from "System.Process" to work with -- @io-streams@. module System.IO.Streams.Process ( module System.Process , runInteractiveCommand , runInteractiveProcess ) where ------------------------------------------------------------------------------ import Data.ByteString.Char8 (ByteString) import System.IO (hClose) import System.Process (CmdSpec (..), CreateProcess (CreateProcess, close_fds, cmdspec, create_group, cwd, std_err, std_in, std_out), ProcessHandle, StdStream (..), createProcess, getProcessExitCode, interruptProcessGroupOf, proc, rawSystem, readProcess, readProcessWithExitCode, runCommand, shell, showCommandForUser, system, terminateProcess, waitForProcess) ------------------------------------------------------------------------------ import qualified System.IO.Streams.Combinators as Streams import qualified System.IO.Streams.Handle as Streams import System.IO.Streams.Internal (InputStream, OutputStream) import qualified System.IO.Streams.Internal as Streams import qualified System.Process as P ------------------------------------------------------------------------------ -- | Runs a command using the shell, and returns streams that may be used to -- communicate with the process via its stdin, stdout, and stderr respectively. -- -- The streams returned by this command are guarded by locks and are therefore -- safe to use in multithreaded code. -- -- /Since: 1.0.2.0/ -- runInteractiveCommand :: String -> IO (OutputStream ByteString, InputStream ByteString, InputStream ByteString, ProcessHandle) runInteractiveCommand scmd = do (hin, hout, herr, ph) <- P.runInteractiveCommand scmd sIn <- Streams.handleToOutputStream hin >>= Streams.atEndOfOutput (hClose hin) >>= Streams.lockingOutputStream sOut <- Streams.handleToInputStream hout >>= Streams.atEndOfInput (hClose hout) >>= Streams.lockingInputStream sErr <- Streams.handleToInputStream herr >>= Streams.atEndOfInput (hClose herr) >>= Streams.lockingInputStream return (sIn, sOut, sErr, ph) ------------------------------------------------------------------------------ -- | Runs a raw command, and returns streams that may be used to communicate -- with the process via its @stdin@, @stdout@ and @stderr@ respectively. -- -- For example, to start a process and feed a string to its stdin: -- -- > (inp,out,err,pid) <- runInteractiveProcess "..." -- > forkIO (Streams.write (Just str) inp) -- -- The streams returned by this command are guarded by locks and are therefore -- safe to use in multithreaded code. -- -- /Since: 1.0.2.0/ -- runInteractiveProcess :: FilePath -- ^ Filename of the executable (see 'proc' for details) -> [String] -- ^ Arguments to pass to the executable -> Maybe FilePath -- ^ Optional path to the working directory -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit) -> IO (OutputStream ByteString, InputStream ByteString, InputStream ByteString, ProcessHandle) runInteractiveProcess cmd args wd env = do (hin, hout, herr, ph) <- P.runInteractiveProcess cmd args wd env sIn <- Streams.handleToOutputStream hin >>= Streams.atEndOfOutput (hClose hin) >>= Streams.lockingOutputStream sOut <- Streams.handleToInputStream hout >>= Streams.atEndOfInput (hClose hout) >>= Streams.lockingInputStream sErr <- Streams.handleToInputStream herr >>= Streams.atEndOfInput (hClose herr) >>= Streams.lockingInputStream return (sIn, sOut, sErr, ph) io-streams-1.5.1.0/src/System/IO/Streams/List.hs0000644000000000000000000001506613423613322017403 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} -- | List conversions and utilities. module System.IO.Streams.List ( -- * List conversions fromList , toList , outputToList , writeList -- * Utility , chunkList , chunkListWith , 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, await, connect, fromConsumer, fromGenerator, makeInputStream, read, 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 <- fromConsumer $ consumer r return (c, flush r) where consumer r = go where go = await >>= (maybe (return $! ()) $ \c -> do liftIO $ modifyMVar_ r $ \dl -> return (dl . (c:)) 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:)) ------------------------------------------------------------------------------ -- | Splits an input stream into chunks whenever @p elt count@ returns true. -- -- Example: -- -- @ -- ghci> 'fromList' [1..14::Int] >>= 'chunkListWith' (\x n -> n>=4) >>= 'toList' -- [[1,2,3,4],[5,6,7,8],[9,10,11,12],[13,14]] -- ghci> 'fromList' ['a'..'z'] >>= 'chunkListWith' (\x n -> n>=4 && x `elem` "aeiouy") >>= 'toList' -- ["abcde","fghi","jklmno","pqrstu","vwxy","z"] -- @ -- -- /Since: 1.3.3.0./ chunkListWith :: (a -> Int -> Bool) -- ^ break predicate -> InputStream a -- ^ stream to process -> IO (InputStream [a]) chunkListWith p input = fromGenerator $ go Nothing 0 id where go v !k dl | Just x <- v, p x k = yield (dl []) >> go Nothing 0 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 (Just x) (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 io-streams-1.5.1.0/src/System/IO/Streams/Builder.hs0000644000000000000000000001567113423613322020060 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# 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 @bytestring@ -- package provides an efficient monoidal datatype used for serializing values -- directly to an output buffer, called a 'Builder', originally implemented in -- the @blaze-builder@ package by Simon Meier. When compiling with @bytestring@ -- versions older than 0.10.4, (i.e. GHC <= 7.6) users must depend on the -- @bytestring-builder@ library to get the new builder implementation. Since we -- try to maintain compatibility with the last three GHC versions, the -- dependency on @bytestring-builder@ can be dropped after the release of GHC -- 7.12. -- -- -- /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' $ 'Data.ByteString.Builder.byteString' \"hello\") newStream -- .... -- @ -- -- -- You can flush the output buffer using 'Data.ByteString.Builder.Extra.flush': -- -- @ -- .... -- Streams.'write' ('Just' 'Data.ByteString.Builder.Extra.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 @handleToOutputStream@ and -- "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 'Data.ByteString.Builder.byteString' l1 ++ ['Data.ByteString.Builder.Extra.flush'] ++ map 'Data.ByteString.Builder.byteString' 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 , builderStreamWithBufferSize , unsafeBuilderStream ) where ------------------------------------------------------------------------------ import Control.Monad (when) import Data.ByteString.Builder.Internal (Buffer (..), BufferRange (..), Builder, byteStringFromBuffer, defaultChunkSize, fillWithBuildStep, newBuffer, runBuilder) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import Data.IORef (newIORef, readIORef, writeIORef) ------------------------------------------------------------------------------ import System.IO.Streams.Internal (OutputStream, makeOutputStream, write, writeTo) ------------------------------------------------------------------------------ builderStreamWithBufferFunc :: IO Buffer -> OutputStream ByteString -> IO (OutputStream Builder) builderStreamWithBufferFunc mkNewBuf os = do ref <- newIORef Nothing makeOutputStream $ chunk ref where chunk ref Nothing = do mbuf <- readIORef ref case mbuf of -- If we existing buffer leftovers, write them to the output. Nothing -> return $! () Just buf -> writeBuf buf write Nothing os chunk ref (Just builder) = runStep ref $ runBuilder builder getBuf ref = readIORef ref >>= maybe mkNewBuf return bumpBuf (Buffer fp (BufferRange !_ endBuf)) endPtr = Buffer fp (BufferRange endPtr endBuf) updateBuf ref buf endPtr = writeIORef ref $! Just $! bumpBuf buf endPtr writeBuf buf = do let bs = byteStringFromBuffer buf when (not . S.null $ bs) $ writeTo os $! Just bs bufRange (Buffer _ rng) = rng runStep ref step = do buf <- getBuf ref fillWithBuildStep step (cDone buf) (cFull buf) (cInsert buf) (bufRange buf) where cDone buf endPtr !() = updateBuf ref buf endPtr cFull buf !endPtr !_ newStep = do writeBuf $! bumpBuf buf endPtr writeIORef ref Nothing runStep ref newStep cInsert buf !endPtr !bs newStep = do writeBuf $! bumpBuf buf endPtr writeIORef ref Nothing writeTo os $! Just bs runStep ref newStep ------------------------------------------------------------------------------ -- | Converts a 'ByteString' sink into a 'Builder' sink, using the supplied -- buffer size. -- -- 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. -- -- /Since: 1.3.0.0./ builderStreamWithBufferSize :: Int -> OutputStream ByteString -> IO (OutputStream Builder) builderStreamWithBufferSize bufsiz = builderStreamWithBufferFunc (newBuffer bufsiz) ------------------------------------------------------------------------------ -- | 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 = builderStreamWithBufferSize defaultChunkSize ------------------------------------------------------------------------------ -- | 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 'Data.ByteString.Builder.Internal.newBuffer'. -- unsafeBuilderStream :: IO Buffer -> OutputStream ByteString -> IO (OutputStream Builder) unsafeBuilderStream mkBuf os = do buf <- mkBuf builderStreamWithBufferFunc (return buf) os io-streams-1.5.1.0/src/System/IO/Streams/Concurrent.hs0000644000000000000000000001001613423613322020600 0ustar0000000000000000-- | Stream utilities for working with concurrent channels. {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} module System.IO.Streams.Concurrent ( -- * Channel conversions inputToChan , chanToInput , chanToOutput , concurrentMerge , makeChanPipe ) where ------------------------------------------------------------------------------ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) #endif import Control.Concurrent (forkIO) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) import Control.Concurrent.MVar (modifyMVar, newEmptyMVar, newMVar, putMVar, takeMVar) import Control.Exception (SomeException, mask, throwIO, try) import Control.Monad (forM_) import Prelude hiding (read) ------------------------------------------------------------------------------ import System.IO.Streams.Internal (InputStream, OutputStream, makeInputStream, makeOutputStream, nullInput, read) ------------------------------------------------------------------------------ -- | 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 = makeInputStream $! readChan ch ------------------------------------------------------------------------------ -- | 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. -- -- Any exceptions raised in one of the worker threads will be trapped and -- re-raised in the current thread. -- -- If the supplied list is empty, `concurrentMerge` will return an empty -- stream. (/Since: 1.5.0.1/) -- concurrentMerge :: [InputStream a] -> IO (InputStream a) concurrentMerge [] = nullInput 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 x <- modifyMVar nleft $ \n -> let !n' = n - 1 in return $! (n', n') if x > 0 then chunk mv nleft else return Nothing Right x -> return x -------------------------------------------------------------------------------- -- | Create a new pair of streams using an underlying 'Chan'. Everything written -- to the 'OutputStream' will appear as-is on the 'InputStream'. -- -- Since reading from the 'InputStream' and writing to the 'OutputStream' are -- blocking calls, be sure to do so in different threads. makeChanPipe :: IO (InputStream a, OutputStream a) makeChanPipe = do chan <- newChan (,) <$> chanToInput chan <*> chanToOutput chan io-streams-1.5.1.0/src/System/IO/Streams/Attoparsec/0000755000000000000000000000000013423613322020231 5ustar0000000000000000io-streams-1.5.1.0/src/System/IO/Streams/Attoparsec/Text.hs0000644000000000000000000000607713423613322021523 0ustar0000000000000000-- | This module provides support for parsing values from Text -- 'InputStream's using @attoparsec@. /Since: 1.4.0.0./ module System.IO.Streams.Attoparsec.Text ( -- * Parsing parseFromStream , parserToInputStream , ParseException(..) ) where ------------------------------------------------------------------------------ import Data.Attoparsec.Text (Parser) import Data.Text (Text) ------------------------------------------------------------------------------ import System.IO.Streams.Internal (InputStream) import qualified System.IO.Streams.Internal as Streams import System.IO.Streams.Internal.Attoparsec (ParseData (..), ParseException (..), parseFromStreamInternal) ------------------------------------------------------------------------------ -- | Supplies an @attoparsec@ 'Parser' with an 'InputStream', returning the -- final parsed value or throwing a 'ParseException' if parsing fails. -- -- 'parseFromStream' consumes only as much input as necessary to satisfy the -- 'Parser': any unconsumed input is pushed back onto the 'InputStream'. -- -- If the 'Parser' exhausts the 'InputStream', the end-of-stream signal is sent -- to attoparsec. -- -- Example: -- -- @ -- ghci> import "Data.Attoparsec.Text" -- ghci> is <- 'System.IO.Streams.fromList' [\"12345xxx\" :: 'Text'] -- ghci> 'parseFromStream' ('Data.Attoparsec.Text.takeWhile' 'Data.Char.isDigit') is -- \"12345\" -- ghci> 'System.IO.Streams.read' is -- Just \"xxx\" -- @ parseFromStream :: Parser r -> InputStream Text -> IO r parseFromStream = parseFromStreamInternal parse feed ------------------------------------------------------------------------------ -- | 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.Text" -- ghci> is <- 'System.IO.Streams.fromList' [\"1 2 3 4 5\" :: 'Text'] -- ghci> let parser = ('Data.Attoparsec.Text.endOfInput' >> 'Control.Applicative.pure' 'Nothing') \<|\> (Just \<$\> ('Data.Attoparsec.Text.skipWhile' 'Data.Attoparsec.Text.isSpace' *> 'Data.Attoparsec.Text.decimal')) -- ghci> 'parserToInputStream' parser is >>= 'System.IO.Streams.toList' -- [1,2,3,4,5] -- ghci> is' \<- 'System.IO.Streams.fromList' [\"1 2xx3 4 5\" :: 'Text'] >>= '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 Text -> IO (InputStream r) parserToInputStream = (Streams.makeInputStream .) . parseFromStream {-# INLINE parserToInputStream #-} io-streams-1.5.1.0/src/System/IO/Streams/Attoparsec/ByteString.hs0000644000000000000000000000633113423613322022662 0ustar0000000000000000-- | This module provides support for parsing values from ByteString -- 'InputStream's using @attoparsec@. /Since: 1.4.0.0./ module System.IO.Streams.Attoparsec.ByteString ( -- * Parsing parseFromStream , parserToInputStream , ParseException(..) ) where ------------------------------------------------------------------------------ import Data.Attoparsec.ByteString.Char8 (Parser) import Data.ByteString (ByteString) ------------------------------------------------------------------------------ import System.IO.Streams.Internal (InputStream) import qualified System.IO.Streams.Internal as Streams import System.IO.Streams.Internal.Attoparsec (ParseData (..), ParseException (..), parseFromStreamInternal) ------------------------------------------------------------------------------ -- | Supplies an @attoparsec@ 'Parser' with an 'InputStream', returning the -- final parsed value or throwing a 'ParseException' if parsing fails. -- -- 'parseFromStream' consumes only as much input as necessary to satisfy the -- 'Parser': any unconsumed input is pushed back onto the 'InputStream'. -- -- If the 'Parser' exhausts the 'InputStream', the end-of-stream signal is sent -- to attoparsec. -- -- 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 ------------------------------------------------------------------------------ -- | 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 #-} io-streams-1.5.1.0/src/System/IO/Streams/Internal/0000755000000000000000000000000013423613322017700 5ustar0000000000000000io-streams-1.5.1.0/src/System/IO/Streams/Internal/Attoparsec.hs0000644000000000000000000001035213423613322022342 0ustar0000000000000000-- | This module provides support for parsing values from 'InputStream's using -- @attoparsec@. {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module System.IO.Streams.Internal.Attoparsec ( -- * Parsing parseFromStreamInternal , ParseData(..) -- * Parse Exceptions , ParseException(..) , eitherResult ) where ------------------------------------------------------------------------------ import Control.Exception (Exception, throwIO) import Control.Monad (unless) import qualified Data.Attoparsec.ByteString.Char8 as S import qualified Data.Attoparsec.Text as T import Data.Attoparsec.Types (IResult (..), Parser) import qualified Data.ByteString as S import Data.List (intercalate) import Data.String (IsString) import qualified Data.Text as T import Data.Typeable (Typeable) import Prelude hiding (null, 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 ------------------------------------------------------------------------------ class (IsString i) => ParseData i where parse :: Parser i a -> i -> IResult i a feed :: IResult i r -> i -> IResult i r null :: i -> Bool ------------------------------------------------------------------------------ instance ParseData S.ByteString where parse = S.parse feed = S.feed null = S.null ------------------------------------------------------------------------------ instance ParseData T.Text where parse = T.parse feed = T.feed null = T.null ------------------------------------------------------------------------------ -- | Internal version of parseFromStream allowing dependency injection of the -- parse functions for testing. parseFromStreamInternal :: ParseData i => (Parser i r -> i -> IResult i r) -> (IResult i r -> i -> IResult i r) -> Parser i r -> InputStream i -> IO r parseFromStreamInternal parseFunc feedFunc parser is = Streams.read is >>= maybe (finish $ parseFunc parser "") (\s -> if null s then parseFromStreamInternal parseFunc feedFunc parser is else go $! parseFunc parser s) where leftover x = unless (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 (!_,c,m)) = eitherResult r in throwIO $ ParseException (ctxMsg c ++ m) ctxMsg [] = "" ctxMsg xs = "[parsing " ++ intercalate "/" xs ++ "] " 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 null s then go r else go $! feedFunc r s) ------------------------------------------------------------------------------ -- A replacement for attoparsec's 'eitherResult', which discards information -- about the context of the failed parse. eitherResult :: IsString i => IResult i r -> Either (i, [String], String) r eitherResult (Done _ r) = Right r eitherResult (Fail residual ctx msg) = Left (residual, ctx, msg) eitherResult _ = Left ("", [], "Result: incomplete input") io-streams-1.5.1.0/src/System/IO/Streams/Internal/Search.hs0000644000000000000000000002005613423613322021444 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} module System.IO.Streams.Internal.Search ( search , MatchInfo(..) ) where ------------------------------------------------------------------------------ import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Control.Monad.ST (ST) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Unsafe as S import qualified Data.Vector.Unboxed as V import qualified Data.Vector.Unboxed.Mutable as MV import Prelude (Bool (..), Either (..), Enum (..), Eq (..), IO, Int, Monad (..), Num (..), Ord (..), Show, either, id, maybe, not, otherwise, ($), ($!), (&&), (.), (||)) ------------------------------------------------------------------------------ import System.IO.Streams.Internal (InputStream) import qualified System.IO.Streams.Internal as Streams ------------------------------------------------------------------------------ -- | 'MatchInfo' provides match information when performing string search. data MatchInfo = Match {-# UNPACK #-} !ByteString | NoMatch {-# UNPACK #-} !ByteString deriving (Show, Eq) ------------------------------------------------------------------------------ -- | Does the given needle match the haystack over the given ranges of indices? matches :: ByteString -- ^ needle -> Int -- ^ needle start -> Int -- ^ needle end (inclusive) -> ByteString -- ^ haystack -> Int -- ^ haystack start -> Int -- ^ haystack end (inclusive) -> Bool matches !needle !nstart !nend' !haystack !hstart !hend' = go nend' hend' where go !nend !hend = if nend < nstart || hend < hstart then True else let !nc = S.unsafeIndex needle nend !hc = S.unsafeIndex haystack hend in if nc /= hc then False else go (nend-1) (hend-1) {-# INLINE matches #-} ------------------------------------------------------------------------------ -- | Given a 'ByteString' to look for (the \"needle\") and an 'InputStream', -- produces a new 'InputStream' which yields data of type 'MatchInfo'. -- -- Example: -- -- @ -- ghci> 'System.IO.Streams.fromList' [\"food\", \"oof\", \"oodles\", \"ok\"] >>= -- 'search' \"foo\" >>= 'System.IO.Streams.toList' -- ['Match' \"foo\",'NoMatch' \"d\",'NoMatch' \"oo\",'Match' \"foo\",'NoMatch' \"dlesok\"] -- @ -- -- Uses the Boyer-Moore-Horspool algorithm -- (). search :: ByteString -- ^ \"needle\" to look for -> InputStream ByteString -- ^ input stream to wrap -> IO (InputStream MatchInfo) search needle stream = Streams.fromGenerator $ lookahead nlen >>= either finishAndEOF startSearch where -------------------------------------------------------------------------- finishAndEOF x = if S.null x then return $! () else Streams.yield $! 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 lastIdx 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 lastIdx 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 Streams.yield $! NoMatch $! S.append haystack crumb startSearch rest -------------------------------------------------------------------------- produceMatch nomatch aftermatch = do when (not $ S.null nomatch) $ Streams.yield $! NoMatch nomatch Streams.yield $! Match needle startSearch aftermatch -------------------------------------------------------------------------- !nlen = S.length needle !lastIdx = nlen - 1 -------------------------------------------------------------------------- !table = V.create $ do t <- MV.replicate 256 nlen go t where go :: forall s . MV.MVector s Int -> ST s (MV.MVector s Int) go !t = go' 0 where go' !i | i >= lastIdx = return t | otherwise = do let c = fromEnum $ S.unsafeIndex needle i MV.unsafeWrite t c (lastIdx - i) go' $! i+1 -------------------------------------------------------------------------- lookahead n = go id n where go dlist !k = liftIO (Streams.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:) io-streams-1.5.1.0/src/System/IO/Streams/Internal/Network.hs0000644000000000000000000000771313423613322021675 0ustar0000000000000000{-# LANGUAGE CPP #-} module System.IO.Streams.Internal.Network ( socketToStreams , socketToStreamsWithBufferSize , socketToStreamsWithBufferSizeImpl ) where ------------------------------------------------------------------------------ import Control.Exception (catch) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Internal as S import Data.Word (Word8) import Foreign.ForeignPtr (newForeignPtr, withForeignPtr) import Foreign.Marshal.Alloc (finalizerFree, mallocBytes) import Foreign.Ptr (Ptr) import Network.Socket (Socket) import qualified Network.Socket as N import qualified Network.Socket.ByteString as NB import Prelude (IO, Int, Maybe (..), return, ($!), (<=), (>>=)) import System.IO.Error (ioError, isEOFError) ------------------------------------------------------------------------------ import System.IO.Streams.Internal (InputStream, OutputStream) import qualified System.IO.Streams.Internal as Streams ------------------------------------------------------------------------------ bUFSIZ :: Int bUFSIZ = 4096 ------------------------------------------------------------------------------ -- | 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 S.ByteString, OutputStream S.ByteString) socketToStreams = socketToStreamsWithBufferSize bUFSIZ ------------------------------------------------------------------------------ -- | Converts a 'Socket' to an 'InputStream' \/ 'OutputStream' pair, with -- control over the size of the receive buffers. 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. socketToStreamsWithBufferSize :: Int -- ^ how large the receive buffer should be -> Socket -- ^ network socket -> IO (InputStream S.ByteString, OutputStream S.ByteString) #if MIN_VERSION_network(2,4,0) socketToStreamsWithBufferSize = socketToStreamsWithBufferSizeImpl N.recvBuf #else socketToStreamsWithBufferSize bufsiz socket = do is <- Streams.makeInputStream input os <- Streams.makeOutputStream output return $! (is, os) where input = do s <- NB.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 NB.sendAll socket s #endif ------------------------------------------------------------------------------ -- | Dependency-injected implementation of socketToStreamsWithBufferSize (for -- testing) socketToStreamsWithBufferSizeImpl :: (N.Socket -> Ptr Word8 -> Int -> IO Int) -- ^ recvBuf -> Int -- ^ how large the receive -- buffer should be -> Socket -- ^ network socket -> IO (InputStream S.ByteString, OutputStream S.ByteString) socketToStreamsWithBufferSizeImpl _recvBuf bufsiz socket = do is <- Streams.makeInputStream input os <- Streams.makeOutputStream output return $! (is, os) where recv buf = _recvBuf socket buf bufsiz `catch` \ioe -> if isEOFError ioe then return 0 else ioError ioe mkFp = mallocBytes bufsiz >>= newForeignPtr finalizerFree input = do fp <- mkFp n <- withForeignPtr fp recv return $! if n <= 0 then Nothing else Just $! S.fromForeignPtr fp 0 n output Nothing = return $! () output (Just s) = if S.null s then return $! () else NB.sendAll socket s