{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Redact.Monad.Terminal
(
MonadTerminal(..)
, redactSGRs
, resetSGRs
, reset
, putLines
, initialize
, putLine
) where
import qualified System.Console.ANSI as Term
import Control.Monad (unless, when)
import Data.Maybe (listToMaybe)
import Prelude hiding (lines, putStr, putStrLn)
import Data.Text (Text)
import qualified Data.Text.IO as TIO
import Redact.Types (Line(NormalLine, RedactLine), Part(Redact, Stet))
class Monad m => MonadTerminal m where
putStr :: Text -> m ()
putStrLn :: Text -> m ()
setSGR :: [Term.SGR] -> m ()
instance MonadTerminal IO where
putStr :: Text -> IO ()
putStr = Text -> IO ()
TIO.putStr
{-# INLINE putStr #-}
putStrLn :: Text -> IO ()
putStrLn = Text -> IO ()
TIO.putStrLn
{-# INLINE putStrLn #-}
setSGR :: [SGR] -> IO ()
setSGR = [SGR] -> IO ()
Term.setSGR
{-# INLINE setSGR #-}
redactSGRs :: Term.Color -> Term.ColorIntensity -> [Term.SGR]
redactSGRs :: Color -> ColorIntensity -> [SGR]
redactSGRs Color
color ColorIntensity
intensity =
[ ConsoleLayer -> ColorIntensity -> Color -> SGR
Term.SetColor ConsoleLayer
Term.Foreground ColorIntensity
intensity Color
color
, ConsoleLayer -> ColorIntensity -> Color -> SGR
Term.SetColor ConsoleLayer
Term.Background ColorIntensity
intensity Color
color
]
resetSGRs :: [Term.SGR]
resetSGRs :: [SGR]
resetSGRs = [SGR
Term.Reset]
reset :: MonadTerminal m => m ()
reset :: forall (m :: * -> *). MonadTerminal m => m ()
reset = forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
resetSGRs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStrLn Text
""
putLines
:: forall m. MonadTerminal m
=> [Term.SGR]
-> [Line]
-> m ()
putLines :: forall (m :: * -> *). MonadTerminal m => [SGR] -> [Line] -> m ()
putLines [SGR]
sgrs [Line]
lines = do
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (forall (m :: * -> *). MonadTerminal m => [SGR] -> Line -> m ()
initialize [SGR]
sgrs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
1 [Line]
lines
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadTerminal m =>
[SGR] -> Line -> Maybe Line -> m ()
putLine [SGR]
sgrs) forall a b. (a -> b) -> a -> b
$
forall a b. [a] -> [b] -> [(a, b)]
zip [Line]
lines ((forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Int -> [a] -> [a]
drop Int
1 [Line]
lines) forall a. [a] -> [a] -> [a]
++ [forall a. Maybe a
Nothing])
initialize
:: MonadTerminal m
=> [Term.SGR]
-> Line
-> m ()
initialize :: forall (m :: * -> *). MonadTerminal m => [SGR] -> Line -> m ()
initialize [SGR]
sgrs = \case
NormalLine{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
RedactLine{} -> forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
sgrs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStrLn Text
""
putLine
:: forall m. MonadTerminal m
=> [Term.SGR]
-> Line
-> Maybe Line
-> m ()
putLine :: forall (m :: * -> *).
MonadTerminal m =>
[SGR] -> Line -> Maybe Line -> m ()
putLine [SGR]
sgrs Line
line Maybe Line
mNextLine = case Line
line of
NormalLine [Part]
parts -> Bool -> [Part] -> m ()
go Bool
False [Part]
parts
RedactLine Text
t
| Bool
isNextRedact -> forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStrLn Text
t
| Bool
otherwise -> forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStr Text
t forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
resetSGRs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStrLn Text
""
where
isNextRedact :: Bool
isNextRedact :: Bool
isNextRedact = case Maybe Line
mNextLine of
Just RedactLine{} -> Bool
True
Maybe Line
_normalLineOrEnd -> Bool
False
go :: Bool -> [Part] -> m ()
go :: Bool -> [Part] -> m ()
go Bool
isRedact [Part
part] = case Part
part of
Stet Text
t -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isRedact forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
resetSGRs
if Bool
isNextRedact
then forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStr Text
t forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
sgrs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStrLn Text
""
else forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStrLn Text
t
Redact Text
t -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isRedact forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
sgrs
if Bool
isNextRedact
then forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStrLn Text
t
else forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStr Text
t forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
resetSGRs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStrLn Text
""
go Bool
isRedact (Part
part:[Part]
parts) = case (Bool
isRedact, Part
part) of
(Bool
False, Stet Text
t) -> forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStr Text
t forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> [Part] -> m ()
go Bool
False [Part]
parts
(Bool
True, Stet Text
t) -> forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
resetSGRs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStr Text
t forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> [Part] -> m ()
go Bool
False [Part]
parts
(Bool
False, Redact Text
t) -> forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
sgrs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStr Text
t forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> [Part] -> m ()
go Bool
True [Part]
parts
(Bool
True, Redact Text
t) -> forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStr Text
t forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> [Part] -> m ()
go Bool
True [Part]
parts
go Bool
_isRedact [] = forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStrLn Text
""