{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Types and functions dealing with strings to be printed on terminal.
module Cli.Extras.TerminalString
  ( TerminalString(..)
  , render
  , putStrWithSGR
  , getTerminalWidth
  , enquiryCode
  ) where

import Control.Monad (when)
import Control.Monad.Catch (bracket_)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (MonadIO)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import System.Console.ANSI
import qualified System.Console.Terminal.Size as TerminalSize
import System.IO (Handle)

-- | Printable text on terminals
--
-- Represents text with an optional color code.
data TerminalString
  = TerminalString_Normal Text
  | TerminalString_Colorized Color Text
  deriving (TerminalString -> TerminalString -> Bool
(TerminalString -> TerminalString -> Bool)
-> (TerminalString -> TerminalString -> Bool) -> Eq TerminalString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TerminalString -> TerminalString -> Bool
$c/= :: TerminalString -> TerminalString -> Bool
== :: TerminalString -> TerminalString -> Bool
$c== :: TerminalString -> TerminalString -> Bool
Eq, Int -> TerminalString -> ShowS
[TerminalString] -> ShowS
TerminalString -> String
(Int -> TerminalString -> ShowS)
-> (TerminalString -> String)
-> ([TerminalString] -> ShowS)
-> Show TerminalString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TerminalString] -> ShowS
$cshowList :: [TerminalString] -> ShowS
show :: TerminalString -> String
$cshow :: TerminalString -> String
showsPrec :: Int -> TerminalString -> ShowS
$cshowsPrec :: Int -> TerminalString -> ShowS
Show, Eq TerminalString
Eq TerminalString =>
(TerminalString -> TerminalString -> Ordering)
-> (TerminalString -> TerminalString -> Bool)
-> (TerminalString -> TerminalString -> Bool)
-> (TerminalString -> TerminalString -> Bool)
-> (TerminalString -> TerminalString -> Bool)
-> (TerminalString -> TerminalString -> TerminalString)
-> (TerminalString -> TerminalString -> TerminalString)
-> Ord TerminalString
TerminalString -> TerminalString -> Bool
TerminalString -> TerminalString -> Ordering
TerminalString -> TerminalString -> TerminalString
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TerminalString -> TerminalString -> TerminalString
$cmin :: TerminalString -> TerminalString -> TerminalString
max :: TerminalString -> TerminalString -> TerminalString
$cmax :: TerminalString -> TerminalString -> TerminalString
>= :: TerminalString -> TerminalString -> Bool
$c>= :: TerminalString -> TerminalString -> Bool
> :: TerminalString -> TerminalString -> Bool
$c> :: TerminalString -> TerminalString -> Bool
<= :: TerminalString -> TerminalString -> Bool
$c<= :: TerminalString -> TerminalString -> Bool
< :: TerminalString -> TerminalString -> Bool
$c< :: TerminalString -> TerminalString -> Bool
compare :: TerminalString -> TerminalString -> Ordering
$ccompare :: TerminalString -> TerminalString -> Ordering
$cp1Ord :: Eq TerminalString
Ord)

printableLength :: [TerminalString] -> Int
printableLength :: [TerminalString] -> Int
printableLength = Text -> Int
T.length (Text -> Int)
-> ([TerminalString] -> Text) -> [TerminalString] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> [TerminalString] -> Text
toText Bool
False

-- Render a list of TerminalString as Text that can be directly putStr'ed.
render
  :: Bool -- ^ with color
  -> Maybe Int -- ^ optionally, trim to maximum width
  -> [TerminalString]
  -> Text
render :: Bool -> Maybe Int -> [TerminalString] -> Text
render withColor :: Bool
withColor w :: Maybe Int
w ts :: [TerminalString]
ts = Maybe Int -> Text -> Text
trim Maybe Int
w (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> [TerminalString] -> Text
toText Bool
withColor [TerminalString]
ts
  where
    trim :: Maybe Int -> Text -> Text
trim = \case
      Nothing -> Text -> Text
forall a. a -> a
id
      Just n :: Int
n -> \s :: Text
s -> if [TerminalString] -> Int
printableLength [TerminalString]
ts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n
        then Int -> Text -> Text
T.take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-3) Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "..." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
resetCode
        else Text
s

toText :: Bool -> [TerminalString] -> Text
toText :: Bool -> [TerminalString] -> Text
toText withColor :: Bool
withColor = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text)
-> ([TerminalString] -> [Text]) -> [TerminalString] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerminalString -> Text) -> [TerminalString] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> TerminalString -> Text
toText' Bool
withColor)

-- | Convert to Text, controlling whether colorization should happen.
toText' :: Bool -> TerminalString -> Text
toText' :: Bool -> TerminalString -> Text
toText' withColor :: Bool
withColor = \case
  TerminalString_Normal s :: Text
s -> Text
s
  TerminalString_Colorized c :: Color
c s :: Text
s -> if Bool
withColor then Color -> Text -> Text
colorizeText Color
c Text
s else Text
s

-- | Colorize the given text so that it is printed in color when using putStr.
colorizeText :: Color -> Text -> Text
colorizeText :: Color -> Text -> Text
colorizeText color :: Color
color s :: Text
s = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
  [ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
color]
  , Text
s
  , String -> Text
T.pack String
resetCode
  ]

-- | Safely print the string with the given ANSI control codes, resetting in the end.
putStrWithSGR :: MonadIO m => [SGR] -> Handle -> Bool -> Text -> m ()
putStrWithSGR :: [SGR] -> Handle -> Bool -> Text -> m ()
putStrWithSGR sgr :: [SGR]
sgr h :: Handle
h withNewLine :: Bool
withNewLine s :: Text
s = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO () -> IO () -> IO ()
forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
bracket_ (Handle -> [SGR] -> IO ()
hSetSGR Handle
h [SGR]
sgr) IO ()
reset (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStr Handle
h Text
s
  where
    reset :: IO ()
reset = Handle -> [SGR] -> IO ()
hSetSGR Handle
h [SGR
Reset] IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
newline -- New line should come *after* reset (to reset cursor color).
    newline :: IO ()
newline = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
withNewLine (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStrLn Handle
h ""

-- | Code for https://en.wikipedia.org/wiki/Enquiry_character. On VT-100
-- descendants (most modern UNIX terminal emulators), an ENQ character
-- can be generated by pressing Ctrl+E.
enquiryCode :: String
enquiryCode :: String
enquiryCode = "\ENQ"

-- | Code to reset ANSI colors
resetCode :: String
resetCode :: String
resetCode = [SGR] -> String
setSGRCode [SGR
Reset]

getTerminalWidth :: IO (Maybe Int)
getTerminalWidth :: IO (Maybe Int)
getTerminalWidth = (Window Int -> Int) -> Maybe (Window Int) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Window Int -> Int
forall a. Window a -> a
TerminalSize.width (Maybe (Window Int) -> Maybe Int)
-> IO (Maybe (Window Int)) -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (Window Int))
forall n. Integral n => IO (Maybe (Window n))
TerminalSize.size