liblawless-0.21.0: Source/IO.hs

{-# LANGUAGE TemplateHaskell, RecordWildCards #-}
{-|
Module:             IO
Description:        General IO functions specialized for 'Printable' instances.
Copyright:          © 2016 All rights reserved.
License:            GPL-3
Maintainer:         Evan Cofsky <evan@theunixman.com>
Stability:          experimental
Portability:        POSIX
-}

module IO (
    getLine,
    hGetLine,
    putStr,
    putStrLn,
    hPutStr,
    hPutStrLn,

    ParseError,
    peReason,
    peStack,

    MonadThrow,
    MonadCatch,
    MonadMask,

    Handle,

    TemporaryFile,
    tfPath,
    tfHandle,

    binaryTemporaryFile,
    textTemporaryFile,

    withOffset,
    withPosition,
    withCurrentPosition,

    MonadIO,
    liftIO,

    IOMode(..),
    binaryFile,
    textFile,

    isEOF,
    close,

    doesFileExist,
    removeFile,

    stdin,
    stdout,
    stderr
    ) where

import Lawless
import Control.Monad.IO.Class
import qualified System.Path.Directory as D
import qualified System.Path.IO as PIO
import qualified Text.IO as TIO
import Text
import Textual
import Path
import qualified System.Path.PartClass as PC
import Exception
import qualified System.IO as SIO
import System.IO (Handle, stdin, stdout, stderr, SeekMode(..), IOMode(..))
import Data.Typeable
import Data.Text.Lazy.Builder (Builder)

default (Text)

-- * Printable I/O to stdio

-- | Exception representing a failure to parse a 'Textual'.
data ParseError = ParseError {
    _peReason ∷ Text,
    _peStack ∷ [Text]
    } deriving (Eq, Ord, Typeable)
makeLenses ''ParseError

instance Printable ParseError where
    print (ParseError {..}) = fsep ": " [
        print "Parse error",
        print _peReason,
        parens $ fsep (print ", ") $ over traversed print _peStack
        ]

instance Show ParseError where
    show = buildString ∘ print

instance Exception ParseError

-- | Try parsing a 'Textual', and throw 'ParseError' if it can't be parsed.
sTxt ∷ (MonadThrow m, Textual t) ⇒ Text → m t
sTxt t = case parseText t of
    Malformed s r → throwM $ ParseError (r ^. packed) $ over traversed (view packed) s
    Parsed v → return v

-- | Read and parse a 'Textual" from 'stdin'.
getLine ∷ (MonadIO m, MonadThrow m, Textual t) ⇒ m t
getLine = TIO.getLine ≫= sTxt

-- | Read and parse a 'Textual' from a 'Handle'.
hGetLine ∷ (MonadIO m, MonadThrow m, Textual t) ⇒ Handle → m t
hGetLine h = TIO.hGetLine h ≫= sTxt

-- putStr ∷ (MonadIO m, Printer p) ⇒ p → m ()

-- | Write a 'Printer' to 'stdout'.
putStr ∷ (MonadIO m) ⇒ Builder  → m ()
putStr = TIO.putStr ∘ buildText

-- putStrLn ∷ (MonadIO m, Printer p) ⇒ p → m ()

-- | Write a 'Printer' plus a newline to 'stdout'.
putStrLn ∷ MonadIO m ⇒ Builder  → m ()
putStrLn = TIO.putStrLn ∘ buildText

-- | Write a 'Printer' to a 'Handle'.
hPutStr ∷ (MonadIO m) ⇒ Handle → Builder → m ()
hPutStr h = TIO.hPutStr h ∘ buildText

-- | Write a 'Printer' plus a newline to 'stderr'.
hPutStrLn ∷ (MonadIO m) ⇒ Handle → Builder → m ()
hPutStrLn h = TIO.hPutStrLn h ∘ buildText

-- * Seek managers

-- | A relative position in a file 'Handle'.
newtype FileOffset = FileOffset Integer
    deriving (Eq, Ord, Show, Enum, Real, Num, Integral, Printable)

-- | An absolute position in a file 'Handle'.
newtype FilePosition = FilePosition Integer
    deriving (Eq, Ord, Show, Enum, Real, Num, Integral, Printable)

-- | Seek relative to the current position in 'Handle'.
rseek ∷ (MonadIO m) ⇒ Handle → FileOffset → m ()
rseek h o = liftIO $ SIO.hSeek h RelativeSeek (fromIntegral o)

-- | Seek to an absolute position in 'Handle'.
aseek ∷ (MonadIO m) ⇒ Handle → FilePosition → m ()
aseek h p = liftIO $ SIO.hSeek h AbsoluteSeek (fromIntegral p)

-- | Get the current 'FilePosition'.
tell ∷ (MonadIO m) ⇒ Handle → m FilePosition
tell h = liftIO $ fromIntegral <$> SIO.hTell h

-- | Function to flush a 'Handle' and seek to a position.
hreturn ∷ (MonadIO m) ⇒ FilePosition → Handle → m ()
hreturn p h = (liftIO $ SIO.hFlush h) ≫ aseek h p

-- | Save the current file position, seek relative to it, perform a
-- function, and then return to the original position.
withOffset ∷ (MonadIO m, MonadMask m) ⇒
    Handle → FileOffset → (Handle → m a) → m a
withOffset h o f= do
    p ← tell h
    bracket_ (rseek h o) (hreturn p h) (f h)

-- | Save the current file position, seek to a new position, perform a
-- function, then return to the original position.
withPosition ∷
    (MonadIO m, MonadMask m) ⇒
    Handle → FilePosition → (Handle → m a) → m a
withPosition h p f = do
    o ← tell h
    bracket_ (aseek h p) (hreturn o h) (f h)

withCurrentPosition ∷ (MonadIO m, MonadMask m) ⇒
    Handle → (Handle → m a) → m a
withCurrentPosition h f = withOffset h 0 f

-- * Managed temporary files

data TemporaryFile = TemporaryFile {
    _tfPath ∷ AbsFile,
    _tfHandle ∷ Handle
    }
makeLenses ''TemporaryFile

temporaryFile ∷ (MonadIO m, MonadMask m) ⇒
    (Handle → m ()) → AbsDir → RelFile → (TemporaryFile → m a) → m a
temporaryFile m pth tmpl =
    let
        openT = do
            (p, h) ← liftIO $ PIO.openTempFile pth tmpl
            m h
            return $ TemporaryFile p h

        closeT tf = do
            liftIO $ PIO.hClose $ tf ^. tfHandle
            liftIO $ D.removeFile $ tf ^. tfPath
    in
        bracket openT closeT

binaryTemporaryFile ∷ (MonadIO m, MonadMask m, MonadThrow m) ⇒
    AbsDir → RelFile → (TemporaryFile → m a) → m a
binaryTemporaryFile = temporaryFile binaryMode

textTemporaryFile ∷ (MonadIO m, MonadMask m, MonadThrow m) ⇒
    AbsDir → RelFile → (TemporaryFile → m a) → m a
textTemporaryFile = temporaryFile textMode

-- * Managed files
open ∷ (MonadIO m, PC.AbsRel ar) ⇒ File ar → IOMode → (Handle → m ()) → m Handle
open p m t = do
    h ← liftIO $ PIO.openBinaryFile p m
    t h
    return h

textMode ∷ MonadIO m ⇒ Handle → m ()
textMode h = liftIO $
    PIO.hSetBuffering h PIO.LineBuffering >>
    PIO.hSetBinaryMode h False

binaryMode ∷ MonadIO m ⇒ Handle → m ()
binaryMode h = liftIO $
    PIO.hSetBuffering h PIO.NoBuffering >>
    PIO.hSetBinaryMode h True

-- | Binary files, no buffering.
binaryFile ∷ (MonadIO m, MonadMask m, PC.AbsRel ar) ⇒
    File ar → IOMode → (Handle → m a) → m a
binaryFile pth m =
    bracket (open pth m binaryMode) (close)

-- | Text files, line-buffered.
textFile ∷ (MonadIO m, MonadMask m, PC.AbsRel ar) ⇒
    File ar → IOMode → (Handle → m a) → m a
textFile pth m = do
    bracket (open pth m textMode) (close)

-- * Lifted IO

isEOF ∷ MonadIO m ⇒ Handle → m Bool
isEOF = liftIO ∘ SIO.hIsEOF

close ∷ MonadIO m ⇒ Handle → m ()
close = liftIO ∘ SIO.hClose

doesFileExist ∷ (MonadIO m, PC.AbsRel ar) ⇒ File ar → m Bool
doesFileExist = liftIO ∘ D.doesFileExist

removeFile ∷ (MonadIO m, PC.AbsRel ar) ⇒ File ar → m ()
removeFile = liftIO ∘ D.removeFile