------------------------------------------------------------------------------
-- |
-- Module      : Redact.Monad.Handle
-- Description : handle I/O
-- Copyright   : Copyright (c) 2020-2022 Travis Cardwell
-- License     : MIT
------------------------------------------------------------------------------

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Redact.Monad.Handle
  ( -- * MonadHandle
    MonadHandle(..)
    -- * Internal
  , handleToTerminal
  , handleToTerminal'
  , fileToTerminal
  , fileToTerminal'
  ) where

-- https://hackage.haskell.org/package/ansi-terminal
import qualified System.Console.ANSI as Term

-- https://hackage.haskell.org/package/base
import Control.Monad (join)
import Data.Bifunctor (first)
import Data.Bool (bool)
import Data.Typeable (Typeable)
import qualified System.IO as IO
import System.IO (Handle, IOMode(ReadMode))
import System.IO.Error (tryIOError)

-- https://hackage.haskell.org/package/text
import Data.Text (Text)
import qualified Data.Text.IO as TIO

-- (redact)
import Redact.Monad.Terminal (MonadTerminal, initialize, putLine)
import Redact.Types (Error(IOError, RedactError), Line)

------------------------------------------------------------------------------
-- $MonadHandle

-- | Handle I/O
--
-- @since 0.4.0.0
class Monad m => MonadHandle m where
  -- | Read a single line from a handle
  hGetLine :: Handle -> m Text

  -- | Check if a handle has more content
  hIsEOF :: Handle -> m Bool

  -- | Open a file and perform an action on its handle
  withFile
    :: Typeable r
    => FilePath
    -> IOMode
    -> (Handle -> m r)
    -> m (Either IOError r)

instance MonadHandle IO where
  hGetLine :: Handle -> IO Text
hGetLine = Handle -> IO Text
TIO.hGetLine
  {-# INLINE hGetLine #-}

  hIsEOF :: Handle -> IO Bool
hIsEOF = Handle -> IO Bool
IO.hIsEOF
  {-# INLINE hIsEOF #-}

  withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO (Either IOError r)
withFile FilePath
path IOMode
mode = IO r -> IO (Either IOError r)
forall a. IO a -> IO (Either IOError a)
tryIOError (IO r -> IO (Either IOError r))
-> ((Handle -> IO r) -> IO r)
-> (Handle -> IO r)
-> IO (Either IOError r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IOMode -> (Handle -> IO r) -> IO r
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile FilePath
path IOMode
mode
  {-# INLINE withFile #-}

------------------------------------------------------------------------------
-- $Internal

-- | Redact text from a 'Handle' strictly, putting it to the terminal
handleToTerminal
  :: forall m s. (MonadHandle m, MonadTerminal m)
  => (s -> Text -> Either String (Line, s))  -- ^ step function
  -> (s -> Maybe String)                     -- ^ end function
  -> s                                       -- ^ initial state
  -> [Term.SGR]  -- ^ 'Term.SGR's for redacted text
  -> Handle
  -> m (Either Error ())
handleToTerminal :: (s -> Text -> Either FilePath (Line, s))
-> (s -> Maybe FilePath)
-> s
-> [SGR]
-> Handle
-> m (Either Error ())
handleToTerminal s -> Text -> Either FilePath (Line, s)
step s -> Maybe FilePath
end s
initialState [SGR]
sgrs Handle
handle =
    Either FilePath (Maybe Line, s) -> m (Either Error ())
begin (Either FilePath (Maybe Line, s) -> m (Either Error ()))
-> m (Either FilePath (Maybe Line, s)) -> m (Either Error ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< s -> m (Either FilePath (Maybe Line, s))
maybeGetLine s
initialState
  where
    maybeGetLine :: s -> m (Either String (Maybe Line, s))
    maybeGetLine :: s -> m (Either FilePath (Maybe Line, s))
maybeGetLine s
state
      = m (Either FilePath (Maybe Line, s))
-> m (Either FilePath (Maybe Line, s))
-> Bool
-> m (Either FilePath (Maybe Line, s))
forall a. a -> a -> Bool -> a
bool
          (((Line, s) -> (Maybe Line, s))
-> Either FilePath (Line, s) -> Either FilePath (Maybe Line, s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Line -> Maybe Line) -> (Line, s) -> (Maybe Line, s)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Line -> Maybe Line
forall a. a -> Maybe a
Just) (Either FilePath (Line, s) -> Either FilePath (Maybe Line, s))
-> (Text -> Either FilePath (Line, s))
-> Text
-> Either FilePath (Maybe Line, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Text -> Either FilePath (Line, s)
step s
state (Text -> Either FilePath (Maybe Line, s))
-> m Text -> m (Either FilePath (Maybe Line, s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> m Text
forall (m :: * -> *). MonadHandle m => Handle -> m Text
hGetLine Handle
handle)
          (Either FilePath (Maybe Line, s)
-> m (Either FilePath (Maybe Line, s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath (Maybe Line, s)
 -> m (Either FilePath (Maybe Line, s)))
-> Either FilePath (Maybe Line, s)
-> m (Either FilePath (Maybe Line, s))
forall a b. (a -> b) -> a -> b
$ (Maybe Line, s) -> Either FilePath (Maybe Line, s)
forall a b. b -> Either a b
Right (Maybe Line
forall a. Maybe a
Nothing, s
state))
      (Bool -> m (Either FilePath (Maybe Line, s)))
-> m Bool -> m (Either FilePath (Maybe Line, s))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> m Bool
forall (m :: * -> *). MonadHandle m => Handle -> m Bool
hIsEOF Handle
handle

    begin :: Either String (Maybe Line, s) -> m (Either Error ())
    begin :: Either FilePath (Maybe Line, s) -> m (Either Error ())
begin = \case
      Right (Just Line
line, s
state) -> do
        [SGR] -> Line -> m ()
forall (m :: * -> *). MonadTerminal m => [SGR] -> Line -> m ()
initialize [SGR]
sgrs Line
line
        Line -> Either FilePath (Maybe Line, s) -> m (Either Error ())
loop Line
line (Either FilePath (Maybe Line, s) -> m (Either Error ()))
-> m (Either FilePath (Maybe Line, s)) -> m (Either Error ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< s -> m (Either FilePath (Maybe Line, s))
maybeGetLine s
state
      Right (Maybe Line
Nothing, s
_state) -> Either Error () -> m (Either Error ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error () -> m (Either Error ()))
-> Either Error () -> m (Either Error ())
forall a b. (a -> b) -> a -> b
$ () -> Either Error ()
forall a b. b -> Either a b
Right ()
      Left FilePath
err -> Either Error () -> m (Either Error ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error () -> m (Either Error ()))
-> (Error -> Either Error ()) -> Error -> m (Either Error ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> m (Either Error ())) -> Error -> m (Either Error ())
forall a b. (a -> b) -> a -> b
$ FilePath -> Error
RedactError FilePath
err

    loop :: Line -> Either String (Maybe Line, s) -> m (Either Error ())
    loop :: Line -> Either FilePath (Maybe Line, s) -> m (Either Error ())
loop Line
line = \case
      Right (Just Line
nextLine, s
state) -> do
        [SGR] -> Line -> Maybe Line -> m ()
forall (m :: * -> *).
MonadTerminal m =>
[SGR] -> Line -> Maybe Line -> m ()
putLine [SGR]
sgrs Line
line (Maybe Line -> m ()) -> Maybe Line -> m ()
forall a b. (a -> b) -> a -> b
$ Line -> Maybe Line
forall a. a -> Maybe a
Just Line
nextLine
        Line -> Either FilePath (Maybe Line, s) -> m (Either Error ())
loop Line
nextLine (Either FilePath (Maybe Line, s) -> m (Either Error ()))
-> m (Either FilePath (Maybe Line, s)) -> m (Either Error ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< s -> m (Either FilePath (Maybe Line, s))
maybeGetLine s
state
      Right (Maybe Line
Nothing, s
state) -> do
        [SGR] -> Line -> Maybe Line -> m ()
forall (m :: * -> *).
MonadTerminal m =>
[SGR] -> Line -> Maybe Line -> m ()
putLine [SGR]
sgrs Line
line Maybe Line
forall a. Maybe a
Nothing
        case s -> Maybe FilePath
end s
state of
          Maybe FilePath
Nothing -> Either Error () -> m (Either Error ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error () -> m (Either Error ()))
-> Either Error () -> m (Either Error ())
forall a b. (a -> b) -> a -> b
$ () -> Either Error ()
forall a b. b -> Either a b
Right ()
          Just FilePath
err -> Either Error () -> m (Either Error ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error () -> m (Either Error ()))
-> (Error -> Either Error ()) -> Error -> m (Either Error ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> m (Either Error ())) -> Error -> m (Either Error ())
forall a b. (a -> b) -> a -> b
$ FilePath -> Error
RedactError FilePath
err
      Left FilePath
err -> do
        [SGR] -> Line -> Maybe Line -> m ()
forall (m :: * -> *).
MonadTerminal m =>
[SGR] -> Line -> Maybe Line -> m ()
putLine [SGR]
sgrs Line
line Maybe Line
forall a. Maybe a
Nothing
        Either Error () -> m (Either Error ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error () -> m (Either Error ()))
-> (Error -> Either Error ()) -> Error -> m (Either Error ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> m (Either Error ())) -> Error -> m (Either Error ())
forall a b. (a -> b) -> a -> b
$ FilePath -> Error
RedactError FilePath
err

------------------------------------------------------------------------------

-- | Redact text from a 'Handle' leniently, putting it to the terminal
handleToTerminal'
  :: forall m s. (MonadHandle m, MonadTerminal m)
  => (s -> Text -> (Line, s))  -- ^ step function
  -> s                         -- ^ initial state
  -> [Term.SGR]                -- ^ 'Term.SGR's for redacted text
  -> Handle
  -> m ()
handleToTerminal' :: (s -> Text -> (Line, s)) -> s -> [SGR] -> Handle -> m ()
handleToTerminal' s -> Text -> (Line, s)
step s
initialState [SGR]
sgrs Handle
handle =
    (Maybe Line, s) -> m ()
begin ((Maybe Line, s) -> m ()) -> m (Maybe Line, s) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< s -> m (Maybe Line, s)
maybeGetLine s
initialState
  where
    maybeGetLine :: s -> m (Maybe Line, s)
    maybeGetLine :: s -> m (Maybe Line, s)
maybeGetLine s
state
      = m (Maybe Line, s) -> m (Maybe Line, s) -> Bool -> m (Maybe Line, s)
forall a. a -> a -> Bool -> a
bool
          ((Line -> Maybe Line) -> (Line, s) -> (Maybe Line, s)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Line -> Maybe Line
forall a. a -> Maybe a
Just ((Line, s) -> (Maybe Line, s))
-> (Text -> (Line, s)) -> Text -> (Maybe Line, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Text -> (Line, s)
step s
state (Text -> (Maybe Line, s)) -> m Text -> m (Maybe Line, s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> m Text
forall (m :: * -> *). MonadHandle m => Handle -> m Text
hGetLine Handle
handle)
          ((Maybe Line, s) -> m (Maybe Line, s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Line
forall a. Maybe a
Nothing, s
state))
      (Bool -> m (Maybe Line, s)) -> m Bool -> m (Maybe Line, s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> m Bool
forall (m :: * -> *). MonadHandle m => Handle -> m Bool
hIsEOF Handle
handle

    begin :: (Maybe Line, s) -> m ()
    begin :: (Maybe Line, s) -> m ()
begin = \case
      (Just Line
line, s
state) -> do
        [SGR] -> Line -> m ()
forall (m :: * -> *). MonadTerminal m => [SGR] -> Line -> m ()
initialize [SGR]
sgrs Line
line
        Line -> (Maybe Line, s) -> m ()
loop Line
line ((Maybe Line, s) -> m ()) -> m (Maybe Line, s) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< s -> m (Maybe Line, s)
maybeGetLine s
state
      (Maybe Line
Nothing, s
_state) -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    loop :: Line -> (Maybe Line, s) -> m ()
    loop :: Line -> (Maybe Line, s) -> m ()
loop Line
line (Maybe Line
mNextLine, s
state) = do
      [SGR] -> Line -> Maybe Line -> m ()
forall (m :: * -> *).
MonadTerminal m =>
[SGR] -> Line -> Maybe Line -> m ()
putLine [SGR]
sgrs Line
line Maybe Line
mNextLine
      case Maybe Line
mNextLine of
        Just Line
nextLine -> Line -> (Maybe Line, s) -> m ()
loop Line
nextLine ((Maybe Line, s) -> m ()) -> m (Maybe Line, s) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< s -> m (Maybe Line, s)
maybeGetLine s
state
        Maybe Line
Nothing -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

------------------------------------------------------------------------------

-- | Redact text from a file strictly, putting it to the terminal
fileToTerminal
  :: (MonadHandle m, MonadTerminal m)
  => (s -> Text -> Either String (Line, s))  -- ^ step function
  -> (s -> Maybe String)                     -- ^ end function
  -> s                                       -- ^ initial state
  -> [Term.SGR]  -- ^ 'Term.SGR's for redacted text
  -> FilePath
  -> m (Either Error ())
fileToTerminal :: (s -> Text -> Either FilePath (Line, s))
-> (s -> Maybe FilePath)
-> s
-> [SGR]
-> FilePath
-> m (Either Error ())
fileToTerminal s -> Text -> Either FilePath (Line, s)
step s -> Maybe FilePath
end s
initialState [SGR]
sgrs FilePath
path
    = (Either IOError (Either Error ()) -> Either Error ())
-> m (Either IOError (Either Error ())) -> m (Either Error ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either Error (Either Error ()) -> Either Error ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Either Error (Either Error ()) -> Either Error ())
-> (Either IOError (Either Error ())
    -> Either Error (Either Error ()))
-> Either IOError (Either Error ())
-> Either Error ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IOError -> Error)
-> Either IOError (Either Error ())
-> Either Error (Either Error ())
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first IOError -> Error
IOError)
    (m (Either IOError (Either Error ())) -> m (Either Error ()))
-> ((Handle -> m (Either Error ()))
    -> m (Either IOError (Either Error ())))
-> (Handle -> m (Either Error ()))
-> m (Either Error ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath
-> IOMode
-> (Handle -> m (Either Error ()))
-> m (Either IOError (Either Error ()))
forall (m :: * -> *) r.
(MonadHandle m, Typeable r) =>
FilePath -> IOMode -> (Handle -> m r) -> m (Either IOError r)
withFile FilePath
path IOMode
ReadMode
    ((Handle -> m (Either Error ())) -> m (Either Error ()))
-> (Handle -> m (Either Error ())) -> m (Either Error ())
forall a b. (a -> b) -> a -> b
$ (s -> Text -> Either FilePath (Line, s))
-> (s -> Maybe FilePath)
-> s
-> [SGR]
-> Handle
-> m (Either Error ())
forall (m :: * -> *) s.
(MonadHandle m, MonadTerminal m) =>
(s -> Text -> Either FilePath (Line, s))
-> (s -> Maybe FilePath)
-> s
-> [SGR]
-> Handle
-> m (Either Error ())
handleToTerminal s -> Text -> Either FilePath (Line, s)
step s -> Maybe FilePath
end s
initialState [SGR]
sgrs

------------------------------------------------------------------------------

-- | Redact text from a file leniently, putting it to the terminal
fileToTerminal'
  :: (MonadHandle m, MonadTerminal m)
  => (s -> Text -> (Line, s))  -- ^ step function
  -> s                         -- ^ initial state
  -> [Term.SGR]                -- ^ 'Term.SGR's for redacted text
  -> FilePath
  -> m (Either Error ())
fileToTerminal' :: (s -> Text -> (Line, s))
-> s -> [SGR] -> FilePath -> m (Either Error ())
fileToTerminal' s -> Text -> (Line, s)
step s
initialState [SGR]
sgrs FilePath
path
    = (Either IOError () -> Either Error ())
-> m (Either IOError ()) -> m (Either Error ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IOError -> Error) -> Either IOError () -> Either Error ()
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first IOError -> Error
IOError)
    (m (Either IOError ()) -> m (Either Error ()))
-> ((Handle -> m ()) -> m (Either IOError ()))
-> (Handle -> m ())
-> m (Either Error ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IOMode -> (Handle -> m ()) -> m (Either IOError ())
forall (m :: * -> *) r.
(MonadHandle m, Typeable r) =>
FilePath -> IOMode -> (Handle -> m r) -> m (Either IOError r)
withFile FilePath
path IOMode
ReadMode
    ((Handle -> m ()) -> m (Either Error ()))
-> (Handle -> m ()) -> m (Either Error ())
forall a b. (a -> b) -> a -> b
$ (s -> Text -> (Line, s)) -> s -> [SGR] -> Handle -> m ()
forall (m :: * -> *) s.
(MonadHandle m, MonadTerminal m) =>
(s -> Text -> (Line, s)) -> s -> [SGR] -> Handle -> m ()
handleToTerminal' s -> Text -> (Line, s)
step s
initialState [SGR]
sgrs