MissingH-1.6.0.3: src/System/IO/Utils.hs
{-# LANGUAGE Trustworthy #-}
{-
Copyright (c) 2004-2011 John Goerzen <jgoerzen@complete.org>
All rights reserved.
For license and copyright information, see the file LICENSE
-}
{- |
Module : System.IO.Utils
Copyright : Copyright (C) 2004-2011 John Goerzen
SPDX-License-Identifier: BSD-3-Clause
Stability : stable
Portability: portable
-}
module System.IO.Utils(-- * Entire File Handle Utilities
-- ** Opened Handle Data Copying
hCopy, hCopyProgress, hLineCopy, lineCopy,
-- ** Disk File Data Copying
copyFileLinesToFile,
-- * Line Processing Utilities
hPutStrLns, hGetLines,
-- * Lazy Interaction
-- ** Character-based
hInteract,
-- ** Line-based
hLineInteract, lineInteract,
-- ** Misc. Lazy
lazyMapM,
-- * Optimizations
optimizeForBatch, optimizeForInteraction
) where
import Data.List (genericLength)
import System.IO (BufferMode (BlockBuffering, LineBuffering),
IOMode (ReadMode, WriteMode), hClose,
hSetBuffering, openFile, stdin, stdout)
import System.IO.HVIO (HVIO (vGetContents, vGetLine, vIsEOF, vPutStr, vPutStrLn))
import System.IO.Unsafe (unsafeInterleaveIO)
{- | Given a list of strings, output a line containing each item, adding
newlines as appropriate. The list is not expected to have newlines already.
-}
hPutStrLns :: HVIO a => a -> [String] -> IO ()
hPutStrLns h = mapM_ $ vPutStrLn h
{- | Given a handle, returns a list of all the lines in that handle.
Thanks to lazy evaluation, this list does not have to be read all at once.
Combined with 'hPutStrLns', this can make a powerful way to develop
filters. See the 'lineInteract' function for more on that concept.
Example:
> main = do
> l <- hGetLines stdin
> hPutStrLns stdout $ filter (startswith "1") l
-}
-- FIXME: does hGetContents h >>= return . lines not work?
hGetLines :: HVIO a => a -> IO [String]
hGetLines h = unsafeInterleaveIO (do
ieof <- vIsEOF h
if (ieof)
then return []
else do
line <- vGetLine h
remainder <- hGetLines h
return (line : remainder))
{- | This is similar to the built-in 'System.IO.interact', but works
on any handle, not just stdin and stdout.
In other words:
> interact = hInteract stdin stdout
-}
hInteract :: (HVIO a, HVIO b) => a -> b -> (String -> String) -> IO ()
hInteract finput foutput func = do
content <- vGetContents finput
vPutStr foutput (func content)
{- | Line-based interaction. This is similar to wrapping your
interact functions with 'lines' and 'unlines'. This equality holds:
> lineInteract = hLineInteract stdin stdout
Here's an example:
> main = lineInteract (filter (startswith "1"))
This will act as a simple version of grep -- all lines that start with 1
will be displayed; all others will be ignored.
-}
lineInteract :: ([String] -> [String]) -> IO ()
lineInteract = hLineInteract stdin stdout
{- | Line-based interaction over arbitrary handles. This is similar
to wrapping hInteract with 'lines' and 'unlines'.
One could view this function like this:
> hLineInteract finput foutput func =
> let newf = unlines . func . lines in
> hInteract finput foutput newf
Though the actual implementation is this for efficiency:
> hLineInteract finput foutput func =
> do
> lines <- hGetLines finput
> hPutStrLns foutput (func lines)
-}
hLineInteract :: (HVIO a, HVIO b) => a -> b -> ([String] -> [String]) -> IO ()
hLineInteract finput foutput func =
do
ls <- hGetLines finput
hPutStrLns foutput (func ls)
{- | Copies from one handle to another in raw mode (using
hGetContents).
-}
hCopy :: (HVIO a, HVIO b) => a -> b -> IO ()
hCopy hin hout = do
c <- vGetContents hin
vPutStr hout c
{- | Copies from one handle to another in raw mode (using hGetContents).
Takes a function to provide progress updates to the user.
-}
hCopyProgress :: (HVIO b, HVIO c, Integral a) =>
b -- ^ Input handle
-> c -- ^ Output handle
-> (Maybe a -> Integer -> Bool -> IO ()) -- ^ Progress function -- the bool is always False unless this is the final call
-> Int -- Block size
-> Maybe a -- Estimated file size (passed to func)
-> IO Integer -- Number of bytes copied
hCopyProgress hin hout func bsize estsize =
let copyFunc :: String -> Integer -> IO Integer
copyFunc [] count = return count
copyFunc indata count =
let block = take bsize indata
remainder = drop bsize indata
newcount = count + (genericLength block)
in
do
vPutStr hout block
func estsize count False
copyFunc remainder newcount
in
do
c <- vGetContents hin
bytes <- copyFunc c 0
func estsize bytes True
return bytes
{- | Copies from one handle to another in text mode (with lines).
Like 'hBlockCopy', this implementation is nice:
> hLineCopy hin hout = hLineInteract hin hout id
-}
hLineCopy :: (HVIO a, HVIO b) => a -> b -> IO()
hLineCopy hin hout = hLineInteract hin hout id
{- | Copies from 'stdin' to 'stdout' using lines. An alias for 'hLineCopy'
over 'stdin' and 'stdout'. -}
lineCopy :: IO ()
lineCopy = hLineCopy stdin stdout
{- | Copies one filename to another in text mode.
Please note that the Unix permission bits are set at a default; you may
need to adjust them after the copy yourself.
This function is implemented using 'hLineCopy' internally. -}
copyFileLinesToFile :: FilePath -> FilePath -> IO ()
copyFileLinesToFile infn outfn = do
hin <- openFile infn ReadMode
hout <- openFile outfn WriteMode
hLineCopy hin hout
hClose hin
hClose hout
return ()
{- | Sets stdin and stdout to be block-buffered. This can save a huge amount
of system resources since far fewer syscalls are made, and can make programs
run much faster. -}
optimizeForBatch :: IO ()
optimizeForBatch = do
hSetBuffering stdin (BlockBuffering (Just 4096))
hSetBuffering stdout (BlockBuffering (Just 4096))
{- | Sets stdin and stdout to be line-buffered. This saves resources
on stdout, but not many on stdin, since it it still looking for newlines. -}
optimizeForInteraction :: IO ()
optimizeForInteraction = do
hSetBuffering stdin LineBuffering
hSetBuffering stdout LineBuffering
{- | Applies a given function to every item in a list, and returns
the new list. Unlike the system\'s mapM, items are evaluated lazily. -}
lazyMapM :: (a -> IO b) -> [a] -> IO [b]
lazyMapM _ [] = return []
lazyMapM conv (x:xs) =
do this <- conv x
next <- unsafeInterleaveIO $ lazyMapM conv xs
return (this:next)