-- | Provides the MonadFileWriter effect.
--
-- @since 0.1
module Effects.FileSystem.HandleWriter
  ( -- * Effect
    MonadHandleWriter (..),
    OsPath,

    -- * UTF-8 Utils
    hPutUtf8,
    hPutNonBlockingUtf8,

    -- * Misc
    die,

    -- * Reexports
    BufferMode (..),
    ByteString,
    IOMode (..),
    Handle,
    SeekMode (..),
    Text,
  )
where

import Control.Exception.Utils (exitFailure)
import Control.Monad.Catch (MonadThrow)
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as Char8
import Data.Text (Text)
import FileSystem.IO qualified as FS.IO
import FileSystem.OsPath (OsPath)
import FileSystem.UTF8 qualified as FS.UTF8
import GHC.Stack (HasCallStack)
import System.IO
  ( BufferMode (BlockBuffering, LineBuffering, NoBuffering),
    Handle,
    IOMode (AppendMode, ReadMode, ReadWriteMode, WriteMode),
    SeekMode (AbsoluteSeek, RelativeSeek, SeekFromEnd),
  )
import System.IO qualified as IO

-- | Represents handle writer effects.
--
-- @since 0.1
class (Monad m) => MonadHandleWriter m where
  -- | Lifted 'FsUtils.openBinaryFileIO'.
  --
  -- @since 0.1
  openBinaryFile :: (HasCallStack) => OsPath -> IOMode -> m Handle

  -- | Lifted 'FsUtils.withBinaryFileIO'.
  --
  -- @since 0.1
  withBinaryFile :: (HasCallStack) => OsPath -> IOMode -> (Handle -> m a) -> m a

  -- | Lifted 'IO.hClose'.
  --
  -- @since 0.1
  hClose :: (HasCallStack) => Handle -> m ()

  -- | Lifted 'IO.hFlush'.
  --
  -- @since 0.1
  hFlush :: (HasCallStack) => Handle -> m ()

  -- | Lifted 'IO.hSetFileSize'.
  --
  -- @since 0.1
  hSetFileSize :: (HasCallStack) => Handle -> Integer -> m ()

  -- | Lifted 'IO.hSetBuffering'.
  --
  -- @since 0.1
  hSetBuffering :: (HasCallStack) => Handle -> BufferMode -> m ()

  -- | Lifted 'IO.hSeek'.
  --
  -- @since 0.1
  hSeek :: (HasCallStack) => Handle -> SeekMode -> Integer -> m ()

  -- | Lifted 'IO.hTell'.
  --
  -- @since 0.1
  hTell :: (HasCallStack) => Handle -> m Integer

  -- | Lifted 'IO.hSetEcho'.
  --
  -- @since 0.1
  hSetEcho :: (HasCallStack) => Handle -> Bool -> m ()

  -- | Lifted 'BS.hPut'.
  --
  -- @since 0.1
  hPut :: (HasCallStack) => Handle -> ByteString -> m ()

  -- | Lifted 'BS.hPutNonBlocking'.
  --
  -- @since 0.1
  hPutNonBlocking :: (HasCallStack) => Handle -> ByteString -> m ByteString

-- | @since 0.1
instance MonadHandleWriter IO where
  openBinaryFile :: HasCallStack => OsPath -> IOMode -> IO Handle
openBinaryFile = OsPath -> IOMode -> IO Handle
FS.IO.openBinaryFileIO
  {-# INLINEABLE openBinaryFile #-}
  withBinaryFile :: forall a.
HasCallStack =>
OsPath -> IOMode -> (Handle -> IO a) -> IO a
withBinaryFile = OsPath -> IOMode -> (Handle -> IO a) -> IO a
forall a. OsPath -> IOMode -> (Handle -> IO a) -> IO a
FS.IO.withBinaryFileIO
  {-# INLINEABLE withBinaryFile #-}
  hClose :: HasCallStack => Handle -> IO ()
hClose = Handle -> IO ()
IO.hClose
  {-# INLINEABLE hClose #-}
  hFlush :: HasCallStack => Handle -> IO ()
hFlush = Handle -> IO ()
IO.hFlush
  {-# INLINEABLE hFlush #-}
  hSetFileSize :: HasCallStack => Handle -> Integer -> IO ()
hSetFileSize = Handle -> Integer -> IO ()
IO.hSetFileSize
  {-# INLINEABLE hSetFileSize #-}
  hSetBuffering :: HasCallStack => Handle -> BufferMode -> IO ()
hSetBuffering = Handle -> BufferMode -> IO ()
IO.hSetBuffering
  {-# INLINEABLE hSetBuffering #-}
  hSeek :: HasCallStack => Handle -> SeekMode -> Integer -> IO ()
hSeek = Handle -> SeekMode -> Integer -> IO ()
IO.hSeek
  {-# INLINEABLE hSeek #-}
  hTell :: HasCallStack => Handle -> IO Integer
hTell = Handle -> IO Integer
IO.hTell
  {-# INLINEABLE hTell #-}
  hSetEcho :: HasCallStack => Handle -> Bool -> IO ()
hSetEcho = Handle -> Bool -> IO ()
IO.hSetEcho
  {-# INLINEABLE hSetEcho #-}
  hPut :: HasCallStack => Handle -> ByteString -> IO ()
hPut = Handle -> ByteString -> IO ()
BS.hPut
  {-# INLINEABLE hPut #-}
  hPutNonBlocking :: HasCallStack => Handle -> ByteString -> IO ByteString
hPutNonBlocking = Handle -> ByteString -> IO ByteString
BS.hPutNonBlocking
  {-# INLINEABLE hPutNonBlocking #-}

-- | @since 0.1
instance (MonadHandleWriter m) => MonadHandleWriter (ReaderT env m) where
  openBinaryFile :: HasCallStack => OsPath -> IOMode -> ReaderT env m Handle
openBinaryFile OsPath
p = m Handle -> ReaderT env m Handle
forall (m :: * -> *) a. Monad m => m a -> ReaderT env m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Handle -> ReaderT env m Handle)
-> (IOMode -> m Handle) -> IOMode -> ReaderT env m Handle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OsPath -> IOMode -> m Handle
forall (m :: * -> *).
(MonadHandleWriter m, HasCallStack) =>
OsPath -> IOMode -> m Handle
openBinaryFile OsPath
p
  {-# INLINEABLE openBinaryFile #-}
  withBinaryFile :: forall a.
HasCallStack =>
OsPath -> IOMode -> (Handle -> ReaderT env m a) -> ReaderT env m a
withBinaryFile OsPath
p IOMode
m Handle -> ReaderT env m a
f =
    ReaderT env m env
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask ReaderT env m env -> (env -> ReaderT env m a) -> ReaderT env m a
forall a b.
ReaderT env m a -> (a -> ReaderT env m b) -> ReaderT env m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m a -> ReaderT env m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT env m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT env m a) -> (env -> m a) -> env -> ReaderT env m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \env
e -> OsPath -> IOMode -> (Handle -> m a) -> m a
forall a.
HasCallStack =>
OsPath -> IOMode -> (Handle -> m a) -> m a
forall (m :: * -> *) a.
(MonadHandleWriter m, HasCallStack) =>
OsPath -> IOMode -> (Handle -> m a) -> m a
withBinaryFile OsPath
p IOMode
m ((ReaderT env m a -> env -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` env
e) (ReaderT env m a -> m a)
-> (Handle -> ReaderT env m a) -> Handle -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> ReaderT env m a
f)
  {-# INLINEABLE withBinaryFile #-}
  hClose :: HasCallStack => Handle -> ReaderT env m ()
hClose = m () -> ReaderT env m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT env m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT env m ())
-> (Handle -> m ()) -> Handle -> ReaderT env m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> m ()
forall (m :: * -> *).
(MonadHandleWriter m, HasCallStack) =>
Handle -> m ()
hClose
  {-# INLINEABLE hClose #-}
  hFlush :: HasCallStack => Handle -> ReaderT env m ()
hFlush = m () -> ReaderT env m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT env m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT env m ())
-> (Handle -> m ()) -> Handle -> ReaderT env m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> m ()
forall (m :: * -> *).
(MonadHandleWriter m, HasCallStack) =>
Handle -> m ()
hFlush
  {-# INLINEABLE hFlush #-}
  hSetFileSize :: HasCallStack => Handle -> Integer -> ReaderT env m ()
hSetFileSize Handle
h = m () -> ReaderT env m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT env m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT env m ())
-> (Integer -> m ()) -> Integer -> ReaderT env m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Integer -> m ()
forall (m :: * -> *).
(MonadHandleWriter m, HasCallStack) =>
Handle -> Integer -> m ()
hSetFileSize Handle
h
  {-# INLINEABLE hSetFileSize #-}
  hSetBuffering :: HasCallStack => Handle -> BufferMode -> ReaderT env m ()
hSetBuffering Handle
h = m () -> ReaderT env m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT env m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT env m ())
-> (BufferMode -> m ()) -> BufferMode -> ReaderT env m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> BufferMode -> m ()
forall (m :: * -> *).
(MonadHandleWriter m, HasCallStack) =>
Handle -> BufferMode -> m ()
hSetBuffering Handle
h
  {-# INLINEABLE hSetBuffering #-}
  hSeek :: HasCallStack => Handle -> SeekMode -> Integer -> ReaderT env m ()
hSeek Handle
h SeekMode
m = m () -> ReaderT env m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT env m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT env m ())
-> (Integer -> m ()) -> Integer -> ReaderT env m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> SeekMode -> Integer -> m ()
forall (m :: * -> *).
(MonadHandleWriter m, HasCallStack) =>
Handle -> SeekMode -> Integer -> m ()
hSeek Handle
h SeekMode
m
  {-# INLINEABLE hSeek #-}
  hTell :: HasCallStack => Handle -> ReaderT env m Integer
hTell = m Integer -> ReaderT env m Integer
forall (m :: * -> *) a. Monad m => m a -> ReaderT env m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Integer -> ReaderT env m Integer)
-> (Handle -> m Integer) -> Handle -> ReaderT env m Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> m Integer
forall (m :: * -> *).
(MonadHandleWriter m, HasCallStack) =>
Handle -> m Integer
hTell
  {-# INLINEABLE hTell #-}
  hSetEcho :: HasCallStack => Handle -> Bool -> ReaderT env m ()
hSetEcho Handle
h = m () -> ReaderT env m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT env m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT env m ())
-> (Bool -> m ()) -> Bool -> ReaderT env m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Bool -> m ()
forall (m :: * -> *).
(MonadHandleWriter m, HasCallStack) =>
Handle -> Bool -> m ()
hSetEcho Handle
h
  {-# INLINEABLE hSetEcho #-}
  hPut :: HasCallStack => Handle -> ByteString -> ReaderT env m ()
hPut Handle
h = m () -> ReaderT env m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT env m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT env m ())
-> (ByteString -> m ()) -> ByteString -> ReaderT env m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> ByteString -> m ()
forall (m :: * -> *).
(MonadHandleWriter m, HasCallStack) =>
Handle -> ByteString -> m ()
hPut Handle
h
  {-# INLINEABLE hPut #-}
  hPutNonBlocking :: HasCallStack => Handle -> ByteString -> ReaderT env m ByteString
hPutNonBlocking Handle
h = m ByteString -> ReaderT env m ByteString
forall (m :: * -> *) a. Monad m => m a -> ReaderT env m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ByteString -> ReaderT env m ByteString)
-> (ByteString -> m ByteString)
-> ByteString
-> ReaderT env m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> ByteString -> m ByteString
forall (m :: * -> *).
(MonadHandleWriter m, HasCallStack) =>
Handle -> ByteString -> m ByteString
hPutNonBlocking Handle
h
  {-# INLINEABLE hPutNonBlocking #-}

-- | Writes the UTF-8 text to the handle.
--
-- @since 0.1
hPutUtf8 :: (HasCallStack, MonadHandleWriter m) => Handle -> Text -> m ()
hPutUtf8 :: forall (m :: * -> *).
(HasCallStack, MonadHandleWriter m) =>
Handle -> Text -> m ()
hPutUtf8 Handle
h = Handle -> ByteString -> m ()
forall (m :: * -> *).
(MonadHandleWriter m, HasCallStack) =>
Handle -> ByteString -> m ()
hPut Handle
h (ByteString -> m ()) -> (Text -> ByteString) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
FS.UTF8.encodeUtf8
{-# INLINEABLE hPutUtf8 #-}

-- | Writes UTF-8 text to handle, returning leftover bytes.
--
-- @since 0.1
hPutNonBlockingUtf8 ::
  ( HasCallStack,
    MonadHandleWriter m
  ) =>
  Handle ->
  Text ->
  m ByteString
hPutNonBlockingUtf8 :: forall (m :: * -> *).
(HasCallStack, MonadHandleWriter m) =>
Handle -> Text -> m ByteString
hPutNonBlockingUtf8 Handle
h = Handle -> ByteString -> m ByteString
forall (m :: * -> *).
(MonadHandleWriter m, HasCallStack) =>
Handle -> ByteString -> m ByteString
hPutNonBlocking Handle
h (ByteString -> m ByteString)
-> (Text -> ByteString) -> Text -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
FS.UTF8.encodeUtf8
{-# INLINEABLE hPutNonBlockingUtf8 #-}

-- | Write given error message to 'IO.stderr' and terminate with `exitFailure`.
--
-- @since 0.1
die :: (HasCallStack, MonadHandleWriter m, MonadThrow m) => String -> m a
die :: forall (m :: * -> *) a.
(HasCallStack, MonadHandleWriter m, MonadThrow m) =>
String -> m a
die String
err = Handle -> ByteString -> m ()
forall (m :: * -> *).
(MonadHandleWriter m, HasCallStack) =>
Handle -> ByteString -> m ()
hPut Handle
IO.stderr ByteString
err' m () -> m a -> m a
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a
forall (m :: * -> *) a. (HasCallStack, MonadThrow m) => m a
exitFailure
  where
    err' :: ByteString
err' = String -> ByteString
Char8.pack String
err