{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Redact.Monad.Handle
(
MonadHandle(..)
, handleToTerminal
, handleToTerminal'
, fileToTerminal
, fileToTerminal'
) where
import qualified System.Console.ANSI as Term
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)
import Data.Text (Text)
import qualified Data.Text.IO as TIO
import Redact.Monad.Terminal (MonadTerminal, initialize, putLine)
import Redact.Types (Error(IOError, RedactError), Line)
class Monad m => MonadHandle m where
hGetLine :: Handle -> m Text
hIsEOF :: Handle -> m Bool
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 #-}
handleToTerminal
:: forall m s. (MonadHandle m, MonadTerminal m)
=> (s -> Text -> Either String (Line, s))
-> (s -> Maybe String)
-> s
-> [Term.SGR]
-> 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
handleToTerminal'
:: forall m s. (MonadHandle m, MonadTerminal m)
=> (s -> Text -> (Line, s))
-> s
-> [Term.SGR]
-> 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 ()
fileToTerminal
:: (MonadHandle m, MonadTerminal m)
=> (s -> Text -> Either String (Line, s))
-> (s -> Maybe String)
-> s
-> [Term.SGR]
-> 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
fileToTerminal'
:: (MonadHandle m, MonadTerminal m)
=> (s -> Text -> (Line, s))
-> s
-> [Term.SGR]
-> 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