{-# 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 :: forall a. HVIO a => a -> [String] -> IO ()
hPutStrLns a
h = (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((String -> IO ()) -> [String] -> IO ())
-> (String -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> String -> IO ()
forall a. HVIO a => a -> String -> IO ()
vPutStrLn a
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 :: forall a. HVIO a => a -> IO [String]
hGetLines a
h = IO [String] -> IO [String]
forall a. IO a -> IO a
unsafeInterleaveIO (do
                                  ieof <- a -> IO Bool
forall a. HVIO a => a -> IO Bool
vIsEOF a
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 :: forall a b.
(HVIO a, HVIO b) =>
a -> b -> (String -> String) -> IO ()
hInteract a
finput b
foutput String -> String
func = do
                                content <- a -> IO String
forall a. HVIO a => a -> IO String
vGetContents a
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 :: ([String] -> [String]) -> IO ()
lineInteract = Handle -> Handle -> ([String] -> [String]) -> IO ()
forall a b.
(HVIO a, HVIO b) =>
a -> b -> ([String] -> [String]) -> IO ()
hLineInteract Handle
stdin Handle
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 :: forall a b.
(HVIO a, HVIO b) =>
a -> b -> ([String] -> [String]) -> IO ()
hLineInteract a
finput b
foutput [String] -> [String]
func =
    do
    ls <- a -> IO [String]
forall a. HVIO a => a -> IO [String]
hGetLines a
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 :: forall a b. (HVIO a, HVIO b) => a -> b -> IO ()
hCopy a
hin b
hout = do
                 c <- a -> IO String
forall a. HVIO a => a -> IO String
vGetContents a
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 :: forall b c a.
(HVIO b, HVIO c, Integral a) =>
b
-> c
-> (Maybe a -> Integer -> Bool -> IO ())
-> Int
-> Maybe a
-> IO Integer
hCopyProgress b
hin c
hout Maybe a -> Integer -> Bool -> IO ()
func Int
bsize Maybe a
estsize =
    let copyFunc :: String -> Integer -> IO Integer
        copyFunc :: String -> Integer -> IO Integer
copyFunc [] Integer
count = Integer -> IO Integer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
count
        copyFunc String
indata Integer
count =
            let block :: String
block = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
bsize String
indata
                remainder :: String
remainder = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
bsize String
indata
                newcount :: Integer
newcount = Integer
count Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (String -> Integer
forall i a. Num i => [a] -> i
genericLength String
block)
                in
                do
                c -> String -> IO ()
forall a. HVIO a => a -> String -> IO ()
vPutStr c
hout String
block
                Maybe a -> Integer -> Bool -> IO ()
func Maybe a
estsize Integer
count Bool
False
                String -> Integer -> IO Integer
copyFunc String
remainder Integer
newcount
        in
        do
        c <- b -> IO String
forall a. HVIO a => a -> IO String
vGetContents b
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 :: forall a b. (HVIO a, HVIO b) => a -> b -> IO ()
hLineCopy a
hin b
hout = a -> b -> ([String] -> [String]) -> IO ()
forall a b.
(HVIO a, HVIO b) =>
a -> b -> ([String] -> [String]) -> IO ()
hLineInteract a
hin b
hout [String] -> [String]
forall a. a -> a
id

{- | Copies from 'stdin' to 'stdout' using lines.  An alias for 'hLineCopy'
over 'stdin' and 'stdout'. -}
lineCopy :: IO ()
lineCopy :: IO ()
lineCopy = Handle -> Handle -> IO ()
forall a b. (HVIO a, HVIO b) => a -> b -> IO ()
hLineCopy Handle
stdin Handle
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 :: String -> String -> IO ()
copyFileLinesToFile String
infn String
outfn = do
                                 hin <- String -> IOMode -> IO Handle
openFile String
infn IOMode
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 :: IO ()
optimizeForBatch = do
                   Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin (Maybe Int -> BufferMode
BlockBuffering (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4096))
                   Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout (Maybe Int -> BufferMode
BlockBuffering (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
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 :: IO ()
optimizeForInteraction = do
                         Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
LineBuffering
                         Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
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 :: forall a b. (a -> IO b) -> [a] -> IO [b]
lazyMapM a -> IO b
_ [] = [b] -> IO [b]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
lazyMapM a -> IO b
conv (a
x:[a]
xs) =
    do this <- a -> IO b
conv a
x
       next <- unsafeInterleaveIO $ lazyMapM conv xs
       return (this:next)