{-# 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)
