{-# 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 (
    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 IO.Base
import qualified System.Path.Directory as D
import qualified System.Path.IO as PIO
import qualified Text.IO as TIO
import Textual
import Printer
import Path
import qualified System.Path.PartClass as PC
import qualified System.IO as SIO
import System.IO (Handle, stdin, stdout, stderr, SeekMode(..), IOMode(..))
import Data.Text.Lazy.Builder (Builder)
import Exception

default (Text)

-- * 'Printable' IO 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