liblawless-0.20.1: 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,

    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

default (Text)

-- * Printable I/O to stdio

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

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

getLine ∷ (MonadIO m, MonadThrow m, Textual t) ⇒ m t
getLine = TIO.getLine ≫= sTxt

hGetLine ∷ (MonadIO m, MonadThrow m, Textual t) ⇒ Handle → m t
hGetLine h = TIO.hGetLine h ≫= sTxt

pTxt ∷ (Printable p)⇒ p → Text
pTxt = buildText ∘ print

putStr ∷ (MonadIO m, Printable p) ⇒ p → m ()
putStr = TIO.putStr ∘ pTxt

putStrLn ∷ (MonadIO m, Printable p) ⇒ p → m ()
putStrLn = TIO.putStrLn ∘ pTxt

hPutStr ∷ (MonadIO m, Printable p) ⇒ Handle → p → m ()
hPutStr h = TIO.hPutStr h ∘ pTxt

hPutStrLn ∷ (MonadIO m, Printable p) ⇒ Handle → p → m ()
hPutStrLn h = TIO.hPutStrLn h ∘ pTxt

-- * Seek managers

newtype FileOffset = FileOffset Integer
    deriving (Eq, Ord, Show, Enum, Real, Num, Integral)
newtype FilePosition = FilePosition Integer
    deriving (Eq, Ord, Show, Enum, Real, Num, Integral)

seek ∷ (MonadIO m) ⇒ Handle → FileOffset → m ()
seek h o = liftIO $ SIO.hSeek h RelativeSeek (fromIntegral o)

seek_ ∷ (MonadIO m) ⇒ Handle → FilePosition → m ()
seek_ h p = liftIO $ SIO.hSeek h AbsoluteSeek (fromIntegral p)

tell ∷ (MonadIO m) ⇒ Handle → m FilePosition
tell h = liftIO $ fromIntegral <$> SIO.hTell h

withOffset ∷ (MonadIO m, MonadMask m) ⇒ Handle → FileOffset → (Handle → m a) → m a
withOffset h o f= do
    p ← tell h
    bracket_ (seek h o) (seek_ h p) (f h)

withPosition ∷ (MonadIO m, MonadMask m) ⇒ Handle → FilePosition → (Handle → m a) → m a
withPosition h p f = do
    o ← tell h
    bracket_ (seek_ h p) (seek_ h o) (f h)

-- * 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