diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,337 @@ +Hi folks, + +We have good news (nevertheless we hope) for all the lazy guys standing there. +Since their birth, lazy IOs have been a great way to modularly leverage all the +good things we have with *pure*, *lazy*, *Haskell* functions to the real world +of files. + +We are happy to present the safe-lazy-io package [1] that does exactly this +and is going to be explained and motivated in the rest of this post. + +=== The context === + +Although these times were hard with the Lazy/IO technique, some people continue +to defend them arguing that all discovered problems about it was not that harmful +and that taking care was sufficient. Indeed some issues have been discovered about +Lazy/IOs, some have been fixed in the underlying machinery, some have just been +hidden and some others are still around. + +== An alternative == + +An alternative design has been proposed --and is still evolving--, it is called +"Iteratee" [2] and has been designed by Oleg Kiselyov. This new design has tons +of advantages over standard imperative IOs, and shares some of the goals of +Lazy/IOs. Iteratee provides a way to do incremental processing in a +high-level style. Indeed both processed data (via enumerators) and processing +code (called iteratee) can be modularly composed. The handling of file-system +resources is precise and safe. Catching errors can be done precisely and can +be interleaved with the processing. In spite of all this, there is an important +drawback: a lot of code has to be re-written and thought in another way. +Processing becomes explicitly chunked which is not always needed and, even +worse, exceptions handling also becomes very explicit. While this makes sense +in a wide range of applications it makes things less natural than the general +case of pure functions. We think that Iteratee have too be studied more, and +we recommend them when you have incrementally react to IO errors. + +== Issues of Standard Lazy/IO == + +We think that we can save Lazy/IO cheaply, but before explaining the way we +solve such and such issue, let's first expose Lazy/IO and its issues. + +One of the main Lazy/IO functions is 'readFile': it takes a file path opens it +and returns the list of characters until the end of the file is reached. The +characteristic of 'readFile' is that only the opening is done strictly, while +the reading is performed lazily as much as the output list is processed. + +Cousins of 'readFile' are 'hGetContents' that takes a file handle and 'getContents' +that reads on the standard input. + +This technique enables to process a file as if the file was completely stored +in memory. Because it is read lazily one knows that only the required part of +the file will be read. Even better, if the input is consumed to produce a +small output or the output is emitted incrementally, then the processing can +be done in constant memory space. + +Examples: +-- Prints the number of words read on stdin +> countWords = print . length . words =<< getContents +-- Prints the length of the longest line +> maxLineLen = print . maximum . map length . lines =<< getContents +-- Prints in lower case the text read on stdin +> lowerText = interact (map toLower) +-- Alternatively +> lowerText = putStr . map toLower =<< getContents + +All these examples are pretty idiomatic Haskell code and make a simple +use of Lazy/IOs. Each of them runs in constant memory space even +if they are declared as if the whole contents were available at once. + +By using stream fusion or 'ByteString''s one can get even faster code while +keeping the code almost the same. Here we will stay with the default list +of 'Char''s data type. However one goal of our approach is to be trivially +adaptable to those data types. + +Using our library will be rougly a matter of namespace switch plus a running +function: + +> lowerText = LI.run' (SIO.putStr . map toLower <$> LI.getContents) + +However we will introducing this library as one goes along. + +Here is another example where the Lazy/IO are still easy to use but no longer +scales well. This program counts the lines of all the files given in arguments: + +> countLines = print . length . lines . concat =<< mapM readFile =<< getArgs + +Here the problem is the limitation of simultaneous opened files. Indeed, +all the files are opened at the beginning therefore reaching the limit easily. + +It's time to recall when the files are closed. With standard Lazy/IOs the +handle is closed when you reach the end of the file, and so when you've +explored the whole list returned by 'readFile'. + +Note also that if you manually open the file and get a handle, then you can +manually close the file, however if by misfortune you close the file and +then still consume the lazy list you will get a truncated list, observing +how much of the file has been read. This last point is due to the fact +that 'readFile' considers the reading error as the end of the file. + +In particular one can fix this program, by simply counting the number of lines +of each file separately and then compute the sum to get the final result. + +> countLines = print . sum =<< mapM (fmap (length . lines) . readFile) =<< getArgs + +However once again this program exhausts the handle resources. Trying +to close the files will not save us either, one just risks getting truncated +files. Indeed the list of intermediate results is produced eagerly but each +intermediate result is lazy and then each file is opened but not immediately +closed since the computation is delayed. +Hopefully adding a bit of strictness cures the problem: + +> countLines = print . sum =<< mapM ((return' . length . lines =<<) . readFile) =<< getArgs +> where return' x = x `seq` return x + +Until there, we have disclosed three problems: + * while reading is lazy, opening is strict, which leads to a less + natural processing of multiple files + * the closing of files is hard to predict + * the errors during reading are silently discarded + +The last one is a bit trickier and has recently been exposed by Oleg Kiselyov [3]. +The problem appears when one gets twice the contents of the same stream---or some kind +of inter-dependent streams. Because reading is implicitly driven by the consumer, the interleaving +of reading may then depend on the reduction strategy employed. This is the case even +if the consumer is a pure function. + +Basically in this example one can observe different values when using one of these functions: +> f1 x y = x `seq` y `seq` x - y +> f2 x y = y `seq` x `seq` x - y + +In this example one reads stdin twice and relies on the error handling to end one stream while +keeping the other opened. Moreover there are other ways to achieve this like the +use of unix fifo files, or using 'getChanContents' from the "Control.Concurrent.Chan" +module. + +=== Our solution === + +Here we will present another design, based on a very simple idea. Our goal is +to provide IO processing in a style very similar to standard Lazy/IO with the +following differences: + - preservation of the determinism; + - a simple control exceptions; + - and a precise management of resources. + +Our solution is made of three key ingredients: a bit of strictness, some predefined +schemas to interleave inputs, some scopes and abstract types to delimit lazy input +operations from strict IO operations. + +== Dealing with a single input == + +Let's present the first ingredient alone through a first example: + +> mapHandleContents :: NFData sa => Handle -> (String -> sa) -> IO sa +> mapHandleContents h f = do +> s <- hGetContents h +> return' (f s) `finally` hClose h + +> return' :: (Monad m, NFData sa) => sa -> m sa +> return' x = rnf x `seq` return x + +It implements some combination of 'fmap' and 'hGetContents'. +Actually some of our examples fit nicely in that model: + +> countWords = print =<< mapHandleContents stdin (length . words) +> maxLineLen = print =<< mapHandleContents stdin (maximum . map length . lines) +> lowerText = putStr =<< mapHandleContents stdin (map toLower) + +However while the two first examples work well in this setting, the third one +tries to allocate the whole result in memory before printing it. + +Here the ingredient that is used is strictness: the purpose in forcing the +result is to be sure that all the needed input is read, before the file is +closed. + +So here we rely on 'NFData' instances to really perform deep forcing---this +kind of assumption is a bit like 'Typeable' instances. +In particular functions must not be an instance of 'NFData': indeed, we have +no way to force lazy values that are stored in the closure of a function. + +The same remark applies to the 'IO' monad for at least three reasons: +'IO' if often represented by functions; lazy 'IORef''s could be used +to hide one input for later use; exceptions with a lazy contents could +also be used to make a lazy value escape. + +Let's now add some more strictness into the meal: the 'SIO' monad! + +== The 'SIO' monad == + +The 'SIO' monad is a thin layer over the 'IO' monad, populated only by +strict 'IO' operations. In particular these operations are strict +in the output, which means that once the output is produced then we know +that the given arguments cannot be further evaluated/forced. +Here is an example of strict IO using the 'SIO' monad: + +> import qualified System.IO.Strict as SIO +> import System.IO.Strict (SIO) +> countWords = SIO.run (SIO.print . length . words =<< SIO.getContents) + +Of course this function does not scale well since it reads the whole +contents in memory before processing it. + +For now the strict-io [4] package contains wrappers for functions +in "System.IO", and strict 'IORef''s. + +One can now introduce a function in lines of 'mapHandleContents': + +> withHandleContents :: NFData sa => Handle -> (String -> SIO sa) -> IO sa +> withHandleContents h f = do +> s <- hGetContents h +> SIO.run (f s) `finally` hClose h + +One can then rewrite 'lowerText' as follow: + +> lowerText = withHandleContents stdin (SIO.putStr . map toLower) + +Until there one can deal quite nicely with single input, many outputs +processing. Currently the only requirement is to delimit a scope where +the resource will be used to return a strict value. + +Dealing with multiple inputs will lead us to our final design of lazy +inputs. + +== Introducing 'LI', Lazy Inputs == + +We first introduce a type for these lazy inputs namely 'LI'. +This type is abstract and we will progressively introduce functions +to build, combine and run them. + +The 'LI' type is a pointed functor, but not necessarily a monad nor +an applicative functor. + +Therefore one exports the 'pure' function as 'pureLI'. Building primitives +allow to read files or handles: + +> LI.pureLI :: a -> LI a +> LI.hGetContents :: Handle -> LI String +> LI.getContents :: LI String +> LI.readFile :: FilePath -> LI String +> LI.getChanContents :: Chan a -> LI [a] + +Being a functor is important: it allows to wholly transform the underlying +input lazily using standard functions about lists for instance: + +> length <$> LI.readFile "foo" +> words <$> LI.readFile "foo" + +Extracting a final value of a lazy input ('LI' type) is a matter of using: + +> LI.run :: (NFData sa) => LI sa -> IO sa +Or +> LI.run' :: (NFData sa) => LI (SIO a) -> IO sa + +One can therefore re-write our examples using lazy inputs: + +> -- embedded printing +> countWords = LI.run' (SIO.print . length . words <$> LI.getContents) +> -- external printing +> maxLineLen = print =<< LI.run (maximum . map length . lines <$> LI.getContents) +> lowerText = LI.run' (SIO.putStr . map toLower <$> LI.getContents) + +== Combining inputs == + +Finally we come to managing multiple inputs. To get both laziness and +precise resource management we will provide dedicated combinators. +The first one is as simple as appending. + +> LI.append :: NFData sa => LI [sa] -> LI [sa] -> LI [sa] + +This one produces a single stream out that sequences the two given streams. +It also sequences the usage of resources: the first resource is closed and +then the second one is opened. + +Note that this combinator is still quite general since one can process each +input beforehand: + +> -- one can drop parts of the inputs +> (take 100 <$> i1) `LI.append` (drop 100 <$> i2) +> -- one can tag each input to know where they come from +> Left <$> i1 `LI.append` Right <$> i2 + +The second one is 'LI.zipWith' which opens the two resources and joins the items +into a single stream. Again, since 'LI' is a functor one can join not only +characters but also words, lines, chunks... A problem with zipping is that it +stops on the shorter input (loosing a part of the other), hopefully one can +prolongate them: + +> zipMaybesWith :: (NFData sa, NFData sb) -> (Maybe sa -> Maybe sb -> c) -> LI [sa] -> LI [sb] -> LI [c] +> zipMaybesWith f xs ys = +> map (uncurry f) . takeWhile someJust <$> zip (prolongate <$> xs) (prolongate <$> ys) +> where someJust (Nothing, Nothing) = False +> someJust _ = True +> prolongate :: [a] -> [Maybe a] +> prolongate zs = map Just zs ++ repeat Nothing + +The last one is 'LI.interleave': + +> LI.interleave :: (NFData sa) -> LI [sa] -> LI [sa] -> LI [sa] + +This function is currently left biased, moreover each resource is closed as soon +as we reach its end. However since the inputs are mixed up together one generally +prefers a tagged version trivially build upon this one: + +> interleaveEither :: (NFData sa, NFData sb) => LI [sa] -> LI [sb] -> LI [Either sa sb] +> interleaveEither a b = interleave (map Left <$> a) (map Right <$> b) + +Here are some final programs that scale well with the number of files. + +> -- number of words in the given files +> main = print =<< LI.run . fmap (length . words) . LI.concat . map LI.readFile =<< getArgs + +> -- almost the same thing but counts words independently in each file +> main = print +> =<< LI.run . fmap sum . LI.sequence . map (fmap (length . words) . LI.readFile) +> =<< getArgs + +> -- prints to stdout swap-cased concatenation of all input files +> main = LI.run' . (fmap (SIO.putStr . fmap swapCase) . LI.concat . map LI.readFile) =<< getArgs +> where swapCase c | isUpper c = toLower c +> | otherwise = toUpper c + +> -- sums character code points of inputs +> main = print =<< LI.run . fmap (sum . map (toInteger . ord)) . LI.concat . map LI.readFile =<< getArgs + +Our solution is from now widely available as an Hackage package named "safe-lazy-io" [4]. + +We hope you will freely enjoy using Lazy/IO again! + +As usual, criticisms, comments, and help are expected! + +Finally, I would like to thank Benoit Montagu and Francois Pottier for helping +me out to polish this work! + +Nicolas Pouillard + +[1]: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/safe-lazy-io +[2]: http://okmij.org/ftp/Streams.html +[3]: http://www.haskell.org/pipermail/haskell/2009-March/021064.html +[4]: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/strict-io diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/System/IO/Lazy/Input.hs b/System/IO/Lazy/Input.hs new file mode 100644 --- /dev/null +++ b/System/IO/Lazy/Input.hs @@ -0,0 +1,218 @@ +-------------------------------------------------------------------- +-- ! +-- Module : System.IO.Lazy.Input +-- Copyright : (c) Nicolas Pouillard 2009 +-- License : BSD3 +-- +-- Maintainer : Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +module System.IO.Lazy.Input +( + -- * Types + LI, + + -- * Running + run, -- :: (NFData sa) => LI sa -> IO sa + run', -- :: (NFData sa) => LI (SIO a) -> IO sa + runAsSIO, -- :: (NFData sa) => LI sa -> SIO sa + runAsSIO', -- :: (NFData sa) => LI sa -> SIO sa + + -- * Basic inputs + pureLI, -- :: a -> LI a + hGetContents, -- :: Handle -> LI String + getContents, -- :: LI String + readFile, -- :: FilePath -> LI String + getChanContents, -- :: Chan a -> LI [a] + + -- * Combining multiple inputs lazily + + -- ** Combining them in sequence + append, -- :: (NFData sa) => LI [sa] -> LI [sa] -> LI [sa] + concat, -- :: (NFData sa) => [LI [sa]] -> LI [sa] + + -- ** Combining them in parallel + interleave, -- :: (NFData sa) => LI [sa] -> LI [sa] -> LI [sa] + interleaveEither, -- :: (NFData sa, NFData sb) => LI [sa] -> LI [sb] -> LI [Either sa sb] + -- interleaveHandles, -- :: Handle -> Handle -> LI [Either Char Char] + zip, -- :: (NFData sa, NFData sb) => LI [sa] -> LI [sb] -> LI [(sa, sb)] + zipWith, -- :: (NFData sa, NFData sb) => (sa -> sb -> c) -> LI [sa] -> LI [sb] -> LI [c] + zipMaybesWith, -- :: (NFData sa, NFData sb) => (Maybe sa -> Maybe sb -> c) -> LI [sa] -> LI [sb] -> LI [c] + zipHandles, -- :: Handle -> Handle -> LI [(Char, Char)] + + -- * Debugging + trace -- :: String -> LI a -> LI a +) +where + +import Prelude hiding (zip, zipWith, readFile, concat, sequence, getContents) +import qualified Data.List as L +import System.IO (Handle) +import qualified System.IO as IO +import System.IO.Unsafe (unsafeInterleaveIO) +import qualified System.IO.Strict as SIO +import qualified System.IO.Strict.Internals as SIO.Internals +import System.IO.Lazy.Input.Internals +import System.IO.Unsafe.GetContents (unsafeHGetContents) +import System.IO.Strict (SIO, return') +import Data.Function +import Control.Parallel.Strategies (NFData(..)) +import Control.Concurrent.Chan (Chan) +import qualified Control.Concurrent.Chan as CH +import Control.Applicative +import Control.Monad hiding (sequence) + +-- | Any pure data can lifted as lazy input. +pureLI :: a -> LI a +pureLI = LI . return . pure + +-- | Extract the data from a lazy input, this is commonly +-- used to actually run the given process over lazy inputs. +-- As in all the functions that requires a 'NFData' instance +-- this means the result will forced using 'rnf'. +run :: NFData sa => LI sa -> IO sa +run = run' . fmap return' + +-- | Pretty much as 'run' expect that one can use strict +-- /IO/s ("System.IO.Strict") to produce the final result. +run' :: NFData sa => LI (SIO sa) -> IO sa +run' (LI startX) = startX >>= finalize . fmap SIO.run + +-- | Pretty much as 'run' but live in the 'SIO' monad instead of 'IO'. +runAsSIO :: NFData sa => LI sa -> SIO sa +runAsSIO = SIO.Internals.wrap1 run + +-- | Pretty much as 'run'' but live in the 'SIO' monad instead of 'IO'. +runAsSIO' :: NFData sa => LI (SIO sa) -> SIO sa +runAsSIO' = SIO.Internals.wrap1 run' + +-- | Returns the contents of the given handle lazily. +hGetContents :: Handle -> LI String +hGetContents h = unsafeHGetContents h `finallyLI` IO.hClose h + +-- | Returns the contents of standard input lazily. +getContents :: LI String +getContents = hGetContents IO.stdin + +-- | Add debugging messages using the given string. +-- This will returns the same lazy input but more verbose. +trace :: String -> LI a -> LI a +trace msg (LI startA) = LI $ do putStrLn $ "Starting " ++ msg + a `Finally` releaseA <- startA + putStrLn $ "Started " ++ msg + return $ Finally a $ do + putStrLn $ "Stopping " ++ msg + releaseA + putStrLn $ "Stopped " ++ msg + +-- | Sequence two lazy inputs that produces lists as one only +-- list. Note that the resource management is precise. As +-- soon as the beginning of the second input is required, +-- the resource of the first input is released and the +-- the second resource is acquired. +append :: NFData sa => LI [sa] -> LI [sa] -> LI [sa] +append (LI startA) (LI startB) = LI $ do + xs `Finally` releaseA <- startA + ~(ys `Finally` releaseB) <- unsafeInterleaveIO $ releaseA >> startB + return $ (rnfList xs ++ ys) `Finally` releaseB + +-- | Same as 'append' but for a list of inputs. +concat :: (NFData sa) => [LI [sa]] -> LI [sa] +concat = foldr append (pureLI []) + +-- | Takes two lazy inputs and returns a single interleaved lazy input. +-- Note that this function is left biased, this is always the left +-- canal that is read first. This function is rarely used directly +-- with file contents since it mixes the two contents, one generally +-- use some tagging to separate them back. Look at 'interleaveEither' +-- for such a function. +interleave :: (NFData sa) => LI [sa] -> LI [sa] -> LI [sa] +interleave (LI startA) (LI startB) = LI $ do + xs0 `Finally` releaseA <- startA + ys0 `Finally` releaseB <- startB + lazyReleaseA <- unsafeInterleaveIO releaseA + lazyReleaseB <- unsafeInterleaveIO releaseB + let loopLeft (x:xs) ys = rnf x `seq` (x : loopRight xs ys) + loopLeft [] ys = lazyReleaseA `seq` ys + loopRight xs (y:ys) = rnf y `seq` (y : loopLeft xs ys) + loopRight xs [] = lazyReleaseB `seq` xs + return $ loopLeft xs0 ys0 `Finally` (lazyReleaseA `seq` lazyReleaseB `seq` return ()) + +-- | Like 'interleave' but it starts by tagging the left input by 'Left' and right +-- input by 'Right' leading to lazy input of 'Either's. +interleaveEither :: (NFData sa, NFData sb) => LI [sa] -> LI [sb] -> LI [Either sa sb] +interleaveEither a b = interleave (map Left <$> a) (map Right <$> b) + +-- use select +{- +-- | This function is very close to a combination of 'interleaveEither' and two +-- 'hGetContents', however it will wait for the first input that is ready +-- to be read. So this one is not left biased. +interleaveHandles :: Handle -> Handle -> LI [Either Char Char] +interleaveHandles h1 h2 = LI $ loop >>= (`Finally` (IO.hClose h1 >> IO.hClose h2)) + where loop = unsafeInterleaveIO $ + (do h1ready <- IO.hReady h1 + if h1ready then readLeft else readRight + ) `catchEOF` (map Right <$> unsafeHGetContents h2) + readRight = (do c <- IO.hGetChar h2 + rest <- loop + return (Right c : rest) + ) `catchEOF` (map Left <$> unsafeHGetContents h1) + readLeft = do c <- IO.hGetChar h1 + rest <- loop + return (Left c : rest) +-} + +-- | Combine two lazy inputs as a single lazy input of pairs. +-- +-- Note that if one input list is short, excess elements of the longer list are discarded. +zip :: (NFData sa, NFData sb) => LI [sa] -> LI [sb] -> LI [(sa, sb)] +zip = zipWith (,) + +-- | 'zipWith' generalize 'zip' with any combining function. +zipWith :: (NFData sa, NFData sb) => (sa -> sb -> c) -> LI [sa] -> LI [sb] -> LI [c] +zipWith f (LI startA) (LI startB) = LI $ do + xs `Finally` releaseA <- startA + ys `Finally` releaseB <- startB + let f' x y = rnf x `seq` rnf y `seq` f x y + return $ L.zipWith f' xs ys `Finally` (releaseA >> releaseB) + +zipMaybesWith :: (NFData sa, NFData sb) => (Maybe sa -> Maybe sb -> c) -> LI [sa] -> LI [sb] -> LI [c] +zipMaybesWith f xs ys = + map (uncurry f) . takeWhile someJust <$> zip (prolongate <$> xs) (prolongate <$> ys) + where someJust (Nothing, Nothing) = False + someJust _ = True + prolongate :: [a] -> [Maybe a] + prolongate zs = map Just zs ++ repeat Nothing + +-- | A shorthand for @\\h1 h2-> zip (hGetContents h1) (hGetContents h2)@. +zipHandles :: Handle -> Handle -> LI [(Char, Char)] +zipHandles = zip `on` hGetContents + +-- | Like 'hGetContents' but it takes a 'FilePath'. +readFile :: FilePath -> LI String +readFile fp = LI $ do + h <- IO.openFile fp IO.ReadMode + x <- unsafeHGetContents h + return $ x `Finally` IO.hClose h + +-- |Return a lazy list representing the contents of the supplied +-- 'Chan', much like 'System.IO.hGetContents'. +getChanContents :: Chan a -> LI [a] +getChanContents ch = nonFinalized go + where go = unsafeInterleaveIO $ do + x <- CH.readChan ch + xs <- go + return (x:xs) + +{- +joinLISIO :: LI (SIO a) -> LI a +joinLISIO x = x !>>= id + +runSIOinIO :: NFData a => LI (SIO a) -> IO a +runSIOinIO = runIO . joinLISIO +-} + diff --git a/System/IO/Lazy/Input/Extra.hs b/System/IO/Lazy/Input/Extra.hs new file mode 100644 --- /dev/null +++ b/System/IO/Lazy/Input/Extra.hs @@ -0,0 +1,137 @@ +-------------------------------------------------------------------- +-- ! +-- Module : System.IO.Lazy.Input +-- Copyright : (c) Nicolas Pouillard 2009 +-- License : BSD3 +-- +-- Maintainer : Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +module System.IO.Lazy.Input.Extra +( + -- ** Various strictier input sequencing + lift2MayForceFirst, -- :: (NFData sa) => (sa -> b -> c) -> LI sa -> LI b -> LI c + lift2ForceFirst, -- :: (NFData sa) => (sa -> b -> c) -> LI sa -> LI b -> LI c + lift2ForceSecond, -- :: (NFData sb) => (a -> sb -> c) -> LI a -> LI sb -> LI c + lift2ForceBoth, -- :: (NFData sa, NFData sb) => (sa -> sb -> c) -> LI sa -> LI sb -> LI c + (!>>=), -- :: (NFData sa) => LI sa -> (sa -> LI b) -> LI b + (=< (sa -> LI b) -> LI sa -> LI b + ap', -- :: (NFData sa) => LI (sa -> b) -> LI sa -> LI b + sequence, -- :: (NFData sa) => [LI sa] -> LI [sa] +) +where + +import Prelude hiding (zip, zipWith, readFile, concat, sequence, getContents) +import System.IO.Unsafe (unsafeInterleaveIO) +import System.IO.Lazy.Input.Internals +import System.IO.Lazy.Input +import Control.Parallel.Strategies (NFData(..)) +import Control.Applicative +import Control.Monad hiding (sequence) + +{- | Lift a pure two arguments function, to a function over lazy inputs. + + Note that the only the first argument /may/ be deeply forced. + In particular it is deeply forced if the function use its second argument. + + The strictness is here to enforce the evaluation order of reading inputs. + + Since too much strictness breaks the interest of lazy inputs, one provides + more specific but lazier combinators like 'append', 'interleave', and 'zip'. +-} +lift2MayForceFirst :: (NFData sa) => (sa -> b -> c) -> LI sa -> LI b -> LI c +lift2MayForceFirst f (LI startA) (LI startB) = LI $ do + x `Finally` releaseA <- startA + y `Finally` releaseB <- startB + lazyReleaseA <- unsafeInterleaveIO releaseA + let r = f x (rnf x `seq` lazyReleaseA `seq` y) + return $ r `Finally` (lazyReleaseA `seq` releaseB) + +{- | Lift a pure two arguments function, to a function over lazy inputs. + + Note that the only the first argument is deeply forced before calling the function. + + The strictness is here to enforce the evaluation order of reading inputs. + + This lifting function can be generalized to n-ary functions, all arguments + but the last one will be deeply forced. + + @ + liftN f mx1 mx2 ... mxN = mx1 !>>= \x1 -> mx2 !>>= \x2 -> ... f x1 x2 <$> mxN + @ +-} +lift2ForceFirst :: (NFData sa) => (sa -> b -> c) -> LI sa -> LI b -> LI c +lift2ForceFirst f mx my = mx !>>= \x -> f x <$> my + +{- Like 'lift2ForceFirst' but only force the second argument. + + This lifting function can be generalized to n-ary functions, all arguments + but the first one will be deeply forced. + + @ + liftN f mx1 mx2 ... mxN = f <$> mx1 `ap'` mx2 `ap'` ... `ap'` mxN + @ +-} +lift2ForceSecond :: (NFData sb) => (a -> sb -> c) -> LI a -> LI sb -> LI c +lift2ForceSecond f mx my = f <$> mx `ap'` my + +{- | Lift a pure two arguments function, to a function over lazy inputs. + + Note that both arguments are deeply forced before calling the function. + See 'lift2ForceFirst' and 'lift2ForceSecond' for lazier versions. + + This one can also be generalized to n-ary functions: + + @ + liftN f mx1 mx2 ... mxN = pureLI f `ap'` mx1 `ap'` mx2 `ap'` ... `ap'` mxN + @ +-} +lift2ForceBoth :: (NFData sa, NFData sb) => (sa -> sb -> c) -> LI sa -> LI sb -> LI c +lift2ForceBoth f mx my = pureLI f `ap'` mx `ap'` my + +-- | Combines a function wrapped as a lazy input and an argument. +-- This is like 'ap' or '<*>' but stricter. +-- +-- Note that since functions types are not member of 'NFData', this function +-- is the only one dealing with functions wrapped as lazy inputs. +-- +-- However as with 'ap' or '<*>', this function generalize 'lift2ForceSecond', 'lift3Fst'... +-- +-- Example: +-- @ +-- lift3Fst f x y z = f <$> x `ap'` y `ap'` z +-- +-- lift3strict f x y z = pureLI f `ap'` x `ap'` y `ap'` z +-- @ +-- +-- The 'ap'' function only deeply force the second argument, so in the case +-- of chaining, the arguments will be forced from left to right. Note that +-- if one starts the chain by lifting the function using 'pureLI', then all +-- the arguments will be forced. One can let one of the arguments lazy +-- by using note however that if one start the chain with '<$>' (same as +-- 'fmap' or 'liftM') then the first argument would not be forced, but one +-- can start with 'pureLI' +ap' :: (NFData sa) => LI (sa -> b) -> LI sa -> LI b +ap' (LI startF) marg = LI $ do + f `Finally` releaseF <- startF + arg <- run marg + return $ f arg `Finally` releaseF +infixl 4 `ap'` + +-- | Turns a list of lazy inputs as an input of list. +sequence :: (NFData sa) => [LI sa] -> LI [sa] +sequence = foldr (lift2ForceFirst (:)) (pureLI []) + +-- | A kind of strict /bind/ over lazy inputs. +infixl 1 !>>= +(!>>=) :: (NFData sa) => LI sa -> (sa -> LI b) -> LI b +ma !>>= f = LI $ run ma >>= startLI . f + +-- | Same as '!>>=' but with arguments flipped. +infixr 1 =< (sa -> LI b) -> LI sa -> LI b +(=<>=) + diff --git a/System/IO/Lazy/Input/Internals.hs b/System/IO/Lazy/Input/Internals.hs new file mode 100644 --- /dev/null +++ b/System/IO/Lazy/Input/Internals.hs @@ -0,0 +1,145 @@ +-------------------------------------------------------------------- +-- | +-- Module : System.IO.Lazy.Input.Internals +-- Copyright : (c) Nicolas Pouillard 2009 +-- License : BSD3 +-- +-- Maintainer : Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +module System.IO.Lazy.Input.Internals +( + -- * Finalized values + Finalized(..), + finalize, + + -- * Lazy inputs internals + LI(..), + nonFinalized, + finallyLI, + + -- * Misc + mapFinalized, + catchEOF, + -- simpleUnsafeHGetContents, + chanFromList, + rnfList +) +where + +import System.IO (Handle) +import qualified System.IO as IO +import qualified System.IO.Error as IO +import System.IO.Unsafe (unsafeInterleaveIO) +import Control.Exception (finally, throwIO) +import Control.Parallel.Strategies (NFData(..)) +import Control.Concurrent.Chan (Chan) +import qualified Control.Concurrent.Chan as CH +import Control.Monad +import Control.Applicative + +-- | Values with their finalizer. +data Finalized a = Finally { finalized :: a + , finalizer :: IO () -- NOTE this field must be lazy, look at 'append' + } + +instance Functor Finalized where + fmap f (a `Finally` finalizeA) = f a `Finally` finalizeA + +instance Applicative Finalized where + pure x = x `Finally` return () + (f `Finally` finalizeF) <*> (x `Finally` finalizeX) = f x `Finally` (finalizeF >> finalizeX) + +-- | Run a /finalized/ computation. +finalize :: Finalized (IO a) -> IO a +finalize (f `Finally` finalizeF) = f `finally` finalizeF + +-- | This the type lazy input data. +-- +-- Note that the lazy input type ('LI') is a member of 'Functor', +-- this means that one can update the contents of the input with +-- any pure function. +-- +-- 'LI' could be a strict monad and a strict applicative functor. +-- However it is not a lazy monad nor a lazy applicative functor as required Haskell. +-- Hopefully it is a lazy (pointed) functor at least. +newtype LI a = LI { startLI :: IO (Finalized a) } + +instance Functor LI where + fmap f = LI . fmap (fmap f) . startLI + +-- | Update the underlying 'Finalized' value. +mapFinalized :: (Finalized a -> Finalized b) -> LI a -> LI b +mapFinalized f = LI . fmap f . startLI + +-- | Build lazy input ('LI') from an 'IO' computation and a 'finalizer'. +finallyLI :: IO a -> IO () -> LI a +finallyLI x finalizeX = LI $ (`Finally` finalizeX) <$> x + +-- | Build lazy input ('LI') from an 'IO' computation. +-- Use this function when the computation does not require a finalizer. +nonFinalized :: IO a -> LI a +nonFinalized = LI . fmap pure + +{- +-- | +-- 'simpleUnsafeHGetContents' behave pretty much the same as +-- 'System.IO.hGetContents' but does not discard I\/O errors encountered +-- which a handle is semi-closed, this is mhy this function is unsafe. +-- +-- Computation 'simpleUnsafeGetContents' @hdl@ returns the list of characters +-- corresponding to the unread portion of the channel or file managed +-- by @hdl@, which is put into an intermediate state, /semi-closed/. +-- In this state, @hdl@ is effectively closed, +-- but items are read from @hdl@ on demand and accumulated in a special +-- list returned by 'simpleUnsafeGetContents' @hdl@. +-- +-- Any operation that fails because a handle is closed, +-- also fails if a handle is semi-closed. The only exception is 'hClose'. +-- A semi-closed handle becomes closed: +-- +-- * if 'hClose' is applied to it; +-- +-- * if an I\/O error occurs when reading an item from the handle; +-- +-- * or once the entire contents of the handle has been read. +-- +-- Once a semi-closed handle becomes closed, the contents of the +-- associated list becomes fixed. The contents of this final list is +-- only partially specified: it will contain at least all the items of +-- the stream that were evaluated prior to the handle becoming closed. +-- +-- Any I\/O errors encountered while a handle is semi-closed are simply +-- discarded. +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file has been reached. +simpleUnsafeHGetContents :: Handle -> IO String +simpleUnsafeHGetContents h = unsafeInterleaveIO $ (do + x <- IO.hGetChar h + xs <- simpleUnsafeHGetContents h + return (x : xs) + ) `catchEOF` return [] +-} + +-- | @x \`catchEOF\` y@ performs @x@ and if it fails due to the EOF error then performs @y@. +catchEOF :: IO a -> IO a -> IO a +x `catchEOF` y = x `catch` (\e -> if IO.isEOFError e then y else throwIO e) + +-- | Take a list and returns a new channel the list written in it. +chanFromList :: [a] -> IO (Chan a) +chanFromList xs = do + ch <- CH.newChan + CH.writeList2Chan ch xs + return ch + +-- | This function lazily returns an element strict list. +-- It is lazier than @rnf@ and stricter than @map (\\x-> rnf x `seq` x)@. +rnfList :: NFData sa => [sa] -> [sa] +rnfList [] = [] +rnfList (x:xs) = rnf x `seq` (x:rnfList xs) + diff --git a/System/IO/Lazy/Input/Tests.hs b/System/IO/Lazy/Input/Tests.hs new file mode 100644 --- /dev/null +++ b/System/IO/Lazy/Input/Tests.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE Rank2Types #-} +-------------------------------------------------------------------- +-- | +-- Module : System.IO.Lazy.Input.Tests +-- Copyright : (c) Nicolas Pouillard 2009 +-- License : BSD3 +-- +-- Maintainer : Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +module System.IO.Lazy.Input.Tests where + +import Prelude hiding (zipWith) +import qualified Data.List as L +import qualified System.IO as IO +import System.IO.Unsafe (unsafeInterleaveIO) +import Control.Parallel.Strategies (NFData(..)) +import Control.Applicative +import Control.Monad +import Data.IORef +import System.IO.Strict (SIO, return') +import qualified System.IO.Strict as SIO +import qualified System.IO.Strict.Internals as SIO +import qualified System.IO.Lazy.Input as LI +import qualified System.IO.Lazy.Input.Extra as LI +import System.IO.Lazy.Input.Internals (LI(..), Finalized(..), chanFromList) +import System.IO.Lazy.Input.Extra ((!>>=), (=< LI [a] +harness (LI start) = LI $ do isOpenRef <- newIORef True + xs0 `Finally` release <- start + let go [] = return [] + go (x:xs) = do isOpen <- readIORef isOpenRef + unless isOpen $ fail msg + xs' <- unsafeInterleaveIO $ go xs + return $ x : xs' + msg = "System.IO.Lazy.Input.harness: try to read a closed input" + xs0' <- unsafeInterleaveIO $ go xs0 + return $ xs0' `Finally` (release >> writeIORef isOpenRef False) + +wrongInterleave :: LI [sa] -> LI [sa] -> LI [sa] +wrongInterleave (LI startA) (LI startB) = LI $ do + xs0 `Finally` releaseA <- startA + ys0 `Finally` releaseB <- startB + lazyReleaseA <- unsafeInterleaveIO releaseA + lazyReleaseB <- unsafeInterleaveIO releaseB + let loopLeft (x:xs) ys = x : loopRight xs ys + loopLeft [] ys = lazyReleaseA `seq` ys + loopRight xs (y:ys) = y : loopLeft xs ys + loopRight xs [] = lazyReleaseB `seq` xs + return $ loopLeft xs0 ys0 `Finally` (lazyReleaseA `seq` lazyReleaseB `seq` return ()) + +wrongZipWith :: (sa -> sb -> c) -> LI [sa] -> LI [sb] -> LI [c] +wrongZipWith f (LI startA) (LI startB) = LI $ do + xs `Finally` releaseA <- startA + ys `Finally` releaseB <- startB + return $ L.zipWith f xs ys `Finally` (releaseA >> releaseB) + +wrongLift2 :: (NFData sc) => (a -> b -> sc) -> LI a -> LI b -> LI sc +wrongLift2 f (LI startA) (LI startB) = LI $ do + x `Finally` releaseA <- startA + y `Finally` releaseB <- startB + let r = f x y + return $ (rnf r `seq` r) `Finally` (releaseA >> releaseB) + +wrongAp :: LI (a -> b) -> LI a -> LI b +wrongAp (LI startF) (LI startArg) = LI $ do + f `Finally` releaseF <- startF + arg `Finally` releaseArg <- startArg + return $ f arg `Finally` (releaseF >> releaseArg) +infixl 4 `wrongAp` + +{- does not compose well since it cannot returns functions +ap' :: (NFData sb) => LI (a -> sb) -> LI a -> LI sb +ap' (LI startF) (LI startArg) = LI $ do + f `Finally` releaseF <- startF + arg `Finally` releaseArg <- startArg + let r = f arg + rnf r `seq` (releaseF >> releaseArg) + return $ r `Finally` return () +infixl 4 `ap'` +-} + +wrongBind :: LI a -> (a -> LI b) -> LI b +LI startA `wrongBind` f = + LI $ do a `Finally` releaseA <- startA + r `Finally` releaseR <- startLI $ f a + return $ r `Finally` (releaseA >> releaseR) + +wrongRun :: NFData a => LI a -> IO a +wrongRun (LI start) = do r `Finally` release <- start + release + return' r + +wrongRun' :: NFData a => LI (SIO a) -> IO a +wrongRun' (LI start) = do f `Finally` release <- start + r <- SIO.rawRun f + release + return' r + +shallowed :: [a] -> [a] +shallowed model = map (model!!) [0..] + +wrongAppend :: NFData sa => LI [sa] -> LI [sa] -> LI [sa] +wrongAppend (LI startA) (LI startB) = LI $ do + xs `Finally` releaseA <- startA + ~(ys `Finally` releaseB) <- unsafeInterleaveIO $ releaseA >> startB + return $ (map (\x->rnf x `seq` x) xs ++ ys) `Finally` releaseB + +veryWrongAppend :: LI [a] -> LI [a] -> LI [a] +veryWrongAppend (LI startA) (LI startB) = LI $ do + xs `Finally` releaseA <- startA + ~(ys `Finally` releaseB) <- unsafeInterleaveIO $ releaseA >> startB + return $ (xs ++ ys) `Finally` releaseB + +testAppend :: (forall sa . NFData sa => LI [sa] -> LI [sa] -> LI [sa]) -> IO Bool +testAppend appe = do ch <- chanFromList [1,(2::Int)] + let mxs = take 2 <$> harness (LI.getChanContents ch) + (==[[4],[3],[1,2]]) <$> LI.run (reverse <$> appe ((:[[3]]) <$> mxs) (pureLI [[4]])) + +test :: ([Int] -> [Int]) -> (([Int] -> [Int] -> Int) -> LI [Int] -> LI [Int] -> LI Int) -> IO Bool +test rewrap tested = (==) <$> g f1 <*> g f2 + where f1 x y = x `seq` y `seq` x - y + f2 x y = y `seq` x `seq` x - y + g f = do ch <- chanFromList [1,2] + let mxs = rewrap <$> harness (shallowed <$> LI.getChanContents ch) + LI.run $ tested (\ a b -> f (head a) (head b)) mxs mxs + +runTests :: IO () +runTests = do + assertIO "lift2ForceFirst" $ test (take 1) LI.lift2ForceFirst + assertIO "lift2ForceSecond" $ test (take 1) LI.lift2ForceSecond + assertIO "lift2ForceBoth" $ test (take 1) LI.lift2ForceBoth + assertIOwrong "wrongLift2" $ test id wrongLift2 + assertIO "lift2MayForceFirst" $ test (take 1) LI.lift2MayForceFirst + assertIO "zipWith" $ test (take 1) (wrapZipWith LI.zipWith) + assertIOwrong "wrongZipWith" $ test id (wrapZipWith wrongZipWith) + assertIOwrong "wrongInterleave" $ test id (wrapInterleave wrongInterleave) + assertIO "interleave" $ test (take 1) (wrapInterleave LI.interleave) + assertIO "ap'" $ test (take 1) (\f x y -> f <$> x `ap'` y) + assertIOwrong "wrongAp" $ test id (\f x y -> f <$> x `wrongAp` y) + assertIO "!>>=" $ test (take 1) (\f mx my -> mx !>>= \x-> my !>>= \y-> pureLI (f x y)) + assertIOwrong "wrongBind" $ test (take 1) (\f mx my -> mx `wrongBind` \x-> my `wrongBind` \y-> pureLI (f x y)) + assertIO "wrongRun'/return'" $ testHarness wrongRun' (return' <$>) + assertIOwrong "wrongRun'/return" $ testHarness wrongRun' (return <$>) + assertIO "LI.append" $ test (take 1) (wrapAppend LI.append) + assertIOwrong "veryWrongAppend" $ test (take 1) (wrapAppend veryWrongAppend) + assertIOwrong "wrongAppend" $ test (take 1) (wrapAppend wrongAppend) + assertIO "testAppend LI.append" $ testAppend LI.append + assertIOwrong "testAppend wrongAppend" $ testAppend wrongAppend + assertIOwrong "testAppend veryWrongAppend" $ testAppend veryWrongAppend + testUnused "id" id + testUnused "LI.append" $ (\i -> take 3 <$> (pureLI "123" `LI.append` i)) + where + assertIOgen pass fail' name mb = do b <- mb `catch` (\e -> trace (show e) (return False)) + putStr (name ++ ": ") + IO.hFlush IO.stdout + putStrLn (if b then pass else fail') + assertIO = assertIOgen (green "PASS") (red "FAIL") + assertIOwrong = assertIOgen (red "PASS (not expected)") (green "FAIL (as expected)") + green x = "\027[K\027[32m" ++ x ++ "\027[0m" + red x = "\027[K\027[31m" ++ x ++ "\027[0m" + wrapZipWith zipW f xs ys = uncurry f . head <$> zipW (,) ((:[]) <$> xs) ((:[]) <$> ys) + wrapInterleave inte f xs ys = let g [a, b] = f a b in g <$> inte ((:[]) <$> xs) ((:[]) <$> ys) + wrapAppend appe f xs ys = let g [a, b] = f [a] [b] in g <$> appe xs ys + testEq ref comp = (==ref) <$> comp + testHarness runner f = testEq [1::Int ..10] $ runner (f $ harness (pureLI [1..10])) + testUnused name f = + assertIOwrong ("testUnused " ++ name) $ LI.run (const True <$> f (LI.readFile "DOESNOTEXISTS")) + diff --git a/System/IO/Unsafe/GetContents.hs b/System/IO/Unsafe/GetContents.hs new file mode 100644 --- /dev/null +++ b/System/IO/Unsafe/GetContents.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.IO.Unsafe.GetContents +-- Copyright : (c) The University of Glasgow, 1992-2001 +-- License : see GHC sources in libraries/base/LICENSE +-- +-- Maintainer : Nicolas Pouillard +-- Stability : internal +-- Portability : non-portable +-- +-- This code is extracted from GHC sources and changed to no longer +-- discards I\/O errors. +----------------------------------------------------------------------------- + +module System.IO.Unsafe.GetContents + (unsafeHGetContents + ,lazyRead) +where + +import Prelude hiding (catch) +import Control.Exception.Extensible (catch) +import System.IO.Unsafe (unsafeInterleaveIO) +import Data.IORef +import GHC.Base +import GHC.Handle +import GHC.IOBase (Buffer(..), Handle__(..), Handle, RawBuffer, IO(IO), FD + ,BufferMode(..), HandleType(..), IOException(..) + ,IOErrorType(..), ioException, bufferEmpty) + + +-- | 'unsafeHGetContents' is pretty much like 'hGetContents' but does not +-- discards I\/O errors get during the lazy reading. +-- +-- This code was copy/pasted from the GHC version of hGetContents. +unsafeHGetContents :: Handle -> IO String +unsafeHGetContents handle = + withHandle "unsafeHGetContents" handle $ \handle_ -> + case haType handle_ of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + AppendHandle -> ioe_notReadable + WriteHandle -> ioe_notReadable + _ -> do xs <- lazyRead handle + return (handle_{ haType=SemiClosedHandle}, xs ) + +-- Note that someone may close the semi-closed handle (or change its +-- buffering), so each time these lazy read functions are pulled on, +-- they have to check whether the handle has indeed been closed. + +lazyRead :: Handle -> IO String +lazyRead handle = + unsafeInterleaveIO $ + withHandle "lazyRead" handle $ \ handle_ -> do + case haType handle_ of + -- here we do not silently returns an empty stream on a closed handle + -- ClosedHandle -> return (handle_, "") + SemiClosedHandle -> lazyRead' handle handle_ + _ -> ioException + (IOError (Just handle) IllegalOperation "lazyRead" + "illegal handle type" Nothing) -- Nothing) + +lazyRead' :: Handle -> Handle__ -> IO (Handle__, [Char]) +lazyRead' h handle_ = do + let ref = haBuffer handle_ + fd = haFD handle_ + + -- even a NoBuffering handle can have a char in the buffer... + -- (see hLookAhead) + buf <- readIORef ref + if not (bufferEmpty buf) + then lazyReadHaveBuffer h handle_ fd ref buf + else do + + case haBufferMode handle_ of + NoBuffering -> do + -- make use of the minimal buffer we already have + let raw = bufBuf buf + r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1 + if r == 0 + then do (handle_', _) <- hClose_help handle_ + return (handle_', "") + else do (c,_) <- readCharFromBuffer raw 0 + rest <- lazyRead h + return (handle_, c : rest) + + LineBuffering -> lazyReadBuffered h handle_ fd ref buf + BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf + +-- we never want to block during the read, so we call fillReadBuffer with +-- is_line==True, which tells it to "just read what there is". +lazyReadBuffered :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer + -> IO (Handle__, [Char]) +lazyReadBuffered h handle_ fd ref buf = -- do + catch + (do buf' <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf + lazyReadHaveBuffer h handle_ fd ref buf' + ) + (\IOError{ioe_type=EOF} -> do (handle_', _) <- hClose_help handle_ + return (handle_', "") + ) +-- Here we do not discard I/O errors, only EOF is caught. +{- + -- all I/O errors are discarded. Additionally, we close the handle. + (\(_ :: SomeException) -> do (handle_', _) <- hClose_help handle_ + return (handle_', "") + ) +-} + +lazyReadHaveBuffer :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer -> IO (Handle__, [Char]) +lazyReadHaveBuffer h handle_ _ ref buf = do + more <- lazyRead h + writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } + s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more + return (handle_, s) + + +unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char] +unpackAcc _ _ 0 acc = return acc +unpackAcc buf (I# r) (I# len) acc0 = IO $ \s -> unpackRB acc0 (len -# 1#) s + where + unpackRB acc i s + | i <# r = (# s, acc #) + | otherwise = + case readCharArray# buf i s of + (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s' diff --git a/examples/cksum.hs b/examples/cksum.hs new file mode 100644 --- /dev/null +++ b/examples/cksum.hs @@ -0,0 +1,4 @@ +import qualified System.IO.Lazy.Input as LI +import System.Environment (getArgs) +import Data.Char +main = print =<< LI.run . fmap (sum . map (toInteger . ord)) . LI.concat . map LI.readFile =<< getArgs diff --git a/examples/count-words.hs b/examples/count-words.hs new file mode 100644 --- /dev/null +++ b/examples/count-words.hs @@ -0,0 +1,23 @@ +import qualified System.IO.Lazy.Input as LI +import System.Environment (getArgs) + +main = print =<< LI.run . fmap (length . words) . LI.concat . map LI.readFile =<< getArgs + +-- some experimentations + +-- main = print =<< fmap sum . mapM (fmap (length . words) . readFile) =<< getArgs +-- main = print =<< LI.run . fmap sum . mapM (fmap (length . words) . LI.readFile) =<< getArgs +-- main = print =<< LI.run . fmap (length . words) . concatLI . map LI.readFile =<< getArgs +-- main = print =<< LI.run . fmap sum . LI.sequence . map (fmap (length . words) . LI.readFile) =<< getArgs +-- main = print =<< LI.run . fmap (length . words . D.toList . runW) . concatLI . map (fmap (W . D.fromList)) . map LI.readFile =<< getArgs + +{- +main = + do args <- getArgs + let onEachFile filePath = do contents <- LI.readFile filePath + return $ length $ words contents + i <- LI.run $ do + counts <- mapM onEachFile args + return $ sum counts + print i +-} diff --git a/examples/std-lazy-io/count-lines-better.hs b/examples/std-lazy-io/count-lines-better.hs new file mode 100644 --- /dev/null +++ b/examples/std-lazy-io/count-lines-better.hs @@ -0,0 +1,2 @@ +import System.Environment +main = print . sum =<< mapM (fmap (length . lines) . readFile) =<< getArgs diff --git a/examples/std-lazy-io/count-lines-good.hs b/examples/std-lazy-io/count-lines-good.hs new file mode 100644 --- /dev/null +++ b/examples/std-lazy-io/count-lines-good.hs @@ -0,0 +1,3 @@ +import System.Environment +main = print . sum =<< mapM ((return' . length . lines =<<) . readFile) =<< getArgs + where return' x = x `seq` return x diff --git a/examples/swap-case.hs b/examples/swap-case.hs new file mode 100644 --- /dev/null +++ b/examples/swap-case.hs @@ -0,0 +1,7 @@ +import System.Environment (getArgs) +import qualified System.IO.Lazy.Input as LI +import qualified System.IO.Strict as SIO +import Data.Char +main = LI.run' . (fmap (SIO.putStr . fmap swapCase) . LI.concat . map LI.readFile) =<< getArgs + where swapCase c | isUpper c = toLower c + | otherwise = toUpper c diff --git a/examples/testhgetcontents.hs b/examples/testhgetcontents.hs new file mode 100644 --- /dev/null +++ b/examples/testhgetcontents.hs @@ -0,0 +1,41 @@ +import Prelude hiding (catch) +import System.IO +import System.IO.Unsafe.GetContents +import GHC.Handle +import Control.Exception + +test name k = do + putStrLn $ " " ++ name + putStrLn . (replicate 4 ' '++) =<< + (fmap show (evaluate =<< k) + `catch` (\e -> return $ "error: " ++ show (e :: SomeException))) + +tests hGetC = do + test "Length OK" $ do + h <- openFile "testhgetcontents.hs" ReadMode + xs <- hGetC h + return $ length xs + test "Length but closed" $ do + h <- openFile "testhgetcontents.hs" ReadMode + xs <- hGetC h + hClose h + return $ length xs + test "Lengths on Double get" $ do + h <- openFile "testhgetcontents.hs" ReadMode + xs <- hGetC h + ys <- hGetC h + let l1 = length xs + l1 `seq` return (l1, length ys) + test "Lengths on dupped get" $ do + h <- openFile "testhgetcontents.hs" ReadMode + duph <- hDuplicate h + xs <- hGetC h + ys <- hGetC duph + let l1 = length xs + l1 `seq` return (l1, length ys) + +main = do + putStrLn "using hGetContents" + tests hGetContents + putStrLn "using unsafeHGetContents" + tests unsafeHGetContents diff --git a/safe-lazy-io.cabal b/safe-lazy-io.cabal new file mode 100644 --- /dev/null +++ b/safe-lazy-io.cabal @@ -0,0 +1,43 @@ +name: safe-lazy-io +cabal-Version: >=1.6 +version: 0.1 +license: BSD3 +license-File: LICENSE +copyright: (c) Nicolas Pouillard +author: Nicolas Pouillard +maintainer: Nicolas Pouillard +category: System +synopsis: A library providing safe lazy IO features. +description: Provides a safer API for incremental IO processing in a way very + close to standard lazy IO. +stability: Provisional +build-type: Simple + +extra-source-files: + README + System/IO/Lazy/Input/Tests.hs + examples/count-words.hs + examples/testhgetcontents.hs + examples/cksum.hs + examples/std-lazy-io/count-lines-good.hs + examples/std-lazy-io/count-lines-better.hs + examples/swap-case.hs + + +library + build-depends: base>=3.0, parallel, strict-io>=0.1, extensible-exceptions + exposed-modules: System.IO.Lazy.Input + System.IO.Lazy.Input.Internals + System.IO.Lazy.Input.Extra + System.IO.Unsafe.GetContents + ghc-options: -Wall -O2 + +-- source-repository head +-- type: darcs +-- location: http://patch-tag.com/publicrepos/safe-lazy-io + +-- source-repository this +-- type: darcs +-- location: http://patch-tag.com/publicrepos/safe-lazy-io +-- tag: 0.1 +