------------------------------------------------------------------------------
-- |
-- Module      : Redact.Monad.Terminal
-- Description : terminal output
-- Copyright   : Copyright (c) 2020-2024 Travis Cardwell
-- License     : MIT
------------------------------------------------------------------------------

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

module Redact.Monad.Terminal
  ( -- * MonadTerminal
    MonadTerminal(..)
    -- * API
  , redactSGRs
  , resetSGRs
  , reset
  , putLines
    -- * Internal
  , initialize
  , putLine
  ) where

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

-- https://hackage.haskell.org/package/base
import Control.Monad (unless, when)
import Data.Maybe (listToMaybe)
import Prelude hiding (lines, putStr, putStrLn)

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

-- (redact)
import Redact.Types (Line(NormalLine, RedactLine), Part(Redact, Stet))

------------------------------------------------------------------------------
-- $MonadTerminal

-- | Terminal output
--
-- @since 0.4.0.0
class Monad m => MonadTerminal m where
  -- | Write a string to the terminal
  putStr :: Text -> m ()

  -- | Write a string to the terminal, appending a newline
  putStrLn :: Text -> m ()

  -- | Set Select Graphic Rendition mode
  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 #-}

------------------------------------------------------------------------------
-- $API

-- | Construct 'Term.SGR's for redacted text
--
-- @since 0.4.0.0
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
    ]

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

-- | 'Term.SGR's for resetting to normal mode
--
-- @since 0.4.0.0
resetSGRs :: [Term.SGR]
resetSGRs :: [SGR]
resetSGRs = [SGR
Term.Reset]

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

-- | Reset the terminal color mode and go to the next line
--
-- @since 0.4.0.0
reset :: MonadTerminal m => m ()
reset :: forall (m :: * -> *). MonadTerminal m => m ()
reset = [SGR] -> m ()
forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
resetSGRs m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> m ()
forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStrLn Text
""

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

-- | Put redacted text to the terminal
--
-- It is assumed that the terminal is set to display normal colors when this
-- function is called.  If the first 'Line' is a 'RedactLine', then an extra
-- blank line is first output in order to set the colors.  The terminal is set
-- to display normal colors when this function exits.
--
-- @since 0.4.0.0
putLines
  :: forall m. MonadTerminal m
  => [Term.SGR]
  -> [Line]
  -> m ()
putLines :: forall (m :: * -> *). MonadTerminal m => [SGR] -> [Line] -> m ()
putLines [SGR]
sgrs [Line]
lines = do
    m () -> (Line -> m ()) -> Maybe Line -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ([SGR] -> Line -> m ()
forall (m :: * -> *). MonadTerminal m => [SGR] -> Line -> m ()
initialize [SGR]
sgrs) (Maybe Line -> m ()) -> ([Line] -> Maybe Line) -> [Line] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Line] -> Maybe Line
forall a. [a] -> Maybe a
listToMaybe ([Line] -> m ()) -> [Line] -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> [Line] -> [Line]
forall a. Int -> [a] -> [a]
take Int
1 [Line]
lines
    ((Line, Maybe Line) -> m ()) -> [(Line, Maybe Line)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Line -> Maybe Line -> m ()) -> (Line, Maybe Line) -> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Line -> Maybe Line -> m ()) -> (Line, Maybe Line) -> m ())
-> (Line -> Maybe Line -> m ()) -> (Line, Maybe Line) -> m ()
forall a b. (a -> b) -> a -> b
$ [SGR] -> Line -> Maybe Line -> m ()
forall (m :: * -> *).
MonadTerminal m =>
[SGR] -> Line -> Maybe Line -> m ()
putLine [SGR]
sgrs) ([(Line, Maybe Line)] -> m ()) -> [(Line, Maybe Line)] -> m ()
forall a b. (a -> b) -> a -> b
$
      [Line] -> [Maybe Line] -> [(Line, Maybe Line)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Line]
lines ((Line -> Maybe Line
forall a. a -> Maybe a
Just (Line -> Maybe Line) -> [Line] -> [Maybe Line]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Line] -> [Line]
forall a. Int -> [a] -> [a]
drop Int
1 [Line]
lines) [Maybe Line] -> [Maybe Line] -> [Maybe Line]
forall a. [a] -> [a] -> [a]
++ [Maybe Line
forall a. Maybe a
Nothing])

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

-- | Initialize the terminal colors
--
-- When the first line is a 'RedactLine', an extra blank line is output in
-- order to set the terminal colors.
initialize
  :: MonadTerminal m
  => [Term.SGR]  -- ^ 'Term.SGR's for redacted text
  -> Line        -- ^ first line
  -> m ()
initialize :: forall (m :: * -> *). MonadTerminal m => [SGR] -> Line -> m ()
initialize [SGR]
sgrs = \case
    NormalLine{} -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    RedactLine{} -> [SGR] -> m ()
forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
sgrs m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> m ()
forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStrLn Text
""

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

-- | Put a line of redacted text to the terminal
--
-- The colors for the line is assumed to be already set.  Be sure to call
-- 'initialize' before putting the first line.
putLine
  :: forall m. MonadTerminal m
  => [Term.SGR]  -- ^ 'Term.SGR's for redacted text
  -> Line        -- ^ line to put
  -> Maybe Line  -- ^ 'Just' next line or 'Nothing' if end
  -> 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 -> Text -> m ()
forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStrLn Text
t
      | Bool
otherwise    -> Text -> m ()
forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStr Text
t m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [SGR] -> m ()
forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
resetSGRs m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> m ()
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
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isRedact (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [SGR] -> m ()
forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
resetSGRs
        if Bool
isNextRedact
          then Text -> m ()
forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStr Text
t m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [SGR] -> m ()
forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
sgrs m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> m ()
forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStrLn Text
""
          else Text -> m ()
forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStrLn Text
t
      Redact Text
t -> do
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isRedact (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [SGR] -> m ()
forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
sgrs
        if Bool
isNextRedact
          then Text -> m ()
forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStrLn Text
t
          else Text -> m ()
forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStr Text
t m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [SGR] -> m ()
forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
resetSGRs m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> m ()
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)   ->                     Text -> m ()
forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStr Text
t m () -> m () -> m ()
forall a b. m a -> m b -> m b
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)   -> [SGR] -> m ()
forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
resetSGRs m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> m ()
forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStr Text
t m () -> m () -> m ()
forall a b. m a -> m b -> m b
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) -> [SGR] -> m ()
forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
sgrs      m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> m ()
forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStr Text
t m () -> m () -> m ()
forall a b. m a -> m b -> m b
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) ->                     Text -> m ()
forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStr Text
t m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> [Part] -> m ()
go Bool
True  [Part]
parts
    go Bool
_isRedact [] = Text -> m ()
forall (m :: * -> *). MonadTerminal m => Text -> m ()
putStrLn Text
""