git.iko.soy/obelisk
on master help sign in
cli: Introduce TerminalString type

This is necessary to correctly count the printable length of a string outputted by the likes of spinner. It allowed us to fix a bug with overflowing spinners in shorter-width terminals.

commit04a8143baf2186d7e34c34aa9b57268aa016586d authorSridhar Ratnakumar <srid@srid.ca> dateFri 25 May 2018, 17:55 (8 years ago) parentca6c8c0
5 files changed+138−55
compare with master
unifiedsplit
lib/command/obelisk-command.cabal+2 lib/command/src/Obelisk/CLI/Logging.hs+25−20 lib/command/src/Obelisk/CLI/Spinner.hs+21−32 lib/command/src/Obelisk/CLI/TerminalString.hs+84 lib/command/src/Obelisk/CLI/Types.hs+6−3
lib/command/obelisk-command.cabal+2
@@ -33,6 +33,7 @@ library
3333 , placeholders
3434 , process
3535 , temporary
36+ , terminal-size
3637 , text
3738 , time
3839 , transformers
@@ -53,6 +54,7 @@ library
5354 Obelisk.CLI.Logging
5455 Obelisk.CLI.Process
5556 Obelisk.CLI.Spinner
57+ Obelisk.CLI.TerminalString
5658 Obelisk.CLI.Types
5759 -- -fobject-code is so that the StaticPointers extension can work in ghci
5860 ghc-options: -Wall -fobject-code
lib/command/src/Obelisk/CLI/Logging.hs+25−20
@@ -12,23 +12,23 @@ module Obelisk.CLI.Logging where
1212import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)
1313import Control.Concurrent.MVar (modifyMVar_, newMVar)
1414import Control.Monad (unless, void, when)
15−import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, bracket, bracket_, catch, throwM)
15+import Control.Monad.Catch (MonadCatch, MonadMask, bracket, catch, throwM)
1616import Control.Monad.IO.Class (liftIO)
17+import Control.Monad.Log (Severity (..), WithSeverity (..), logMessage, runLoggingT)
1718import Control.Monad.Loops (iterateUntil)
1819import Control.Monad.Reader (MonadIO, ReaderT (..))
20+import Data.IORef (atomicModifyIORef', newIORef, readIORef, writeIORef)
1921import Data.Semigroup ((<>))
2022import Data.Text (Text)
2123import qualified Data.Text as T
2224import qualified Data.Text.IO as T
2325import System.Console.ANSI (Color (Red, White, Yellow), ColorIntensity (Vivid),
2426 ConsoleIntensity (FaintIntensity), ConsoleLayer (Foreground),
25− SGR (Reset, SetColor, SetConsoleIntensity), clearLine, setSGR)
27+ SGR (SetColor, SetConsoleIntensity), clearLine)
2628import System.Exit (ExitCode (..), exitWith)
2729import System.IO (BufferMode (NoBuffering), hFlush, hReady, hSetBuffering, stdin, stdout)
2830
29−import Control.Monad.Log (MonadLog, Severity (..), WithSeverity (..), logMessage, runLoggingT)
30−import Data.IORef (atomicModifyIORef', newIORef, readIORef, writeIORef)
31−
31+import qualified Obelisk.CLI.TerminalString as TS
3232import Obelisk.CLI.Types
3333
3434newCliConfig :: Severity -> Bool -> Bool -> IO CliConfig
@@ -89,12 +89,16 @@ handleLog' :: MonadIO m => Bool -> Output -> m Bool
8989handleLog' noColor output = do
9090 case output of
9191 Output_Log m -> liftIO $ do
92− writeLogWith T.putStrLn noColor m
92+ writeLog True noColor m
9393 Output_LogRaw m -> liftIO $ do
94− writeLogWith T.putStr noColor m
94+ writeLog False noColor m
9595 hFlush stdout -- Explicitly flush, as there is no newline
96− Output_Overwrite xs -> liftIO $ do
97− mapM_ putStr $ "\r" : xs
96+ Output_Write ts -> liftIO $ do
97+ T.putStrLn $ TS.render (not noColor) Nothing ts
98+ hFlush stdout
99+ Output_Overwrite ts -> liftIO $ do
100+ width <- TS.getTerminalWidth
101+ T.putStr $ "\r" <> (TS.render (not noColor) width ts)
98102 hFlush stdout
99103 Output_ClearLine -> liftIO $ do
100104 -- Go to the first column and clear the whole line
@@ -122,7 +126,7 @@ failWith s = do
122126-- | Intercept ExitFailure exceptions and log the given alert before exiting.
123127--
124128-- This is useful when you want to provide contextual information to a deeper failure.
125−withExitFailMessage :: (MonadIO m, MonadLog Output m, MonadCatch m, MonadThrow m) => Text -> m a -> m a
129+withExitFailMessage :: (Cli m, MonadCatch m) => Text -> m a -> m a
126130withExitFailMessage msg f = f `catch` \(e :: ExitCode) -> do
127131 case e of
128132 ExitFailure _ -> putLog Alert msg
@@ -130,17 +134,18 @@ withExitFailMessage msg f = f `catch` \(e :: ExitCode) -> do
130134 throwM e
131135
132136-- | Write log to stdout, with colors (unless `noColor`)
133−writeLogWith :: (MonadIO m, MonadMask m) => (Text -> IO ()) -> Bool -> WithSeverity Text -> m ()
134−writeLogWith f noColor (WithSeverity severity s)
135− | noColor && severity <= Warning = liftIO $ f $ T.pack (show severity) <> ": " <> s
136− | not noColor && severity <= Error = put [SetColor Foreground Vivid Red]
137− | not noColor && severity <= Warning = put [SetColor Foreground Vivid Yellow]
138− | not noColor && severity >= Debug = put [SetColor Foreground Vivid White, SetConsoleIntensity FaintIntensity]
139− | otherwise = liftIO $ f s
137+writeLog:: (MonadIO m, MonadMask m) => Bool -> Bool -> WithSeverity Text -> m ()
138+writeLog withNewLine noColor (WithSeverity severity s)
139+ | noColor && severity <= Warning = liftIO $ putFn $ T.pack (show severity) <> ": " <> s
140+ | not noColor && severity <= Error = TS.putStrWithSGR errorColors withNewLine s
141+ | not noColor && severity <= Warning = TS.putStrWithSGR warningColors withNewLine s
142+ | not noColor && severity >= Debug = TS.putStrWithSGR debugColors withNewLine s
143+ | otherwise = liftIO $ putFn s
140144 where
141− -- We must reset *before* outputting the newline (if any), otherwise the cursor won't be reset.
142− reset = setSGR [Reset] >> f ""
143− put sgr = liftIO $ bracket_ (setSGR sgr) reset $ T.putStr s
145+ putFn = if withNewLine then T.putStrLn else T.putStr
146+ errorColors = [SetColor Foreground Vivid Red]
147+ warningColors = [SetColor Foreground Vivid Yellow]
148+ debugColors = [SetColor Foreground Vivid White, SetConsoleIntensity FaintIntensity]
144149
145150-- | Allow the user to immediately switch to verbose logging upon pressing a particular key.
146151--
lib/command/src/Obelisk/CLI/Spinner.hs+21−32
@@ -11,13 +11,12 @@ import Control.Monad.IO.Class
1111import Control.Monad.Log (logMessage)
1212import Control.Monad.Reader (MonadIO)
1313import Data.IORef
14−import Data.List (delete)
14+import qualified Data.List as L
1515import Data.Text (Text)
16−import qualified Data.Text as T
17−import System.Console.ANSI (Color (Blue, Cyan, Green, Red), ColorIntensity (Vivid), ConsoleLayer (Foreground),
18− SGR (Reset, SetColor), setSGRCode)
16+import System.Console.ANSI (Color (Blue, Cyan, Green, Red))
1917
2018import Obelisk.CLI.Logging (allowUserToMakeLoggingVerbose, fork)
19+import Obelisk.CLI.TerminalString (TerminalString (..), enquiryCode)
2120import Obelisk.CLI.Types (Cli, CliConfig (..), HasCliConfig, Output (..), getCliConfig)
2221
2322-- | Run an action with a CLI spinner.
@@ -33,12 +32,12 @@ withSpinner s = bracket' start cleanup . const
3332 run = do
3433 -- Add this log to the spinner stack
3534 stack <- _cliConfig_spinnerStack <$> getCliConfig
36− wasEmpty <- liftIO $ atomicModifyIORef' stack $ \old -> (s : old, null old)
35+ wasEmpty <- liftIO $ atomicModifyIORef' stack $ \old -> (TerminalString_Normal s : old, null old)
3736 if wasEmpty
3837 then do -- Fork a thread to manage output of anything on the stack
3938 tid <- fork $ runSpinner spinner $ \c -> do
4039 logs <- liftIO $ concatStack c <$> readIORef stack
41− logMessage $ Output_Overwrite [logs]
40+ logMessage $ Output_Overwrite logs
4241 pure [tid]
4342 else pure []
4443 cleanup failed tids = do
@@ -46,36 +45,37 @@ withSpinner s = bracket' start cleanup . const
4645 liftIO $ mapM_ killThread tids
4746 logMessage Output_ClearLine
4847 let mark = if failed
49− then withColor Red "✖"
50− else withColor Green "✔"
48+ then TerminalString_Colorized Red "✖"
49+ else TerminalString_Colorized Green "✔"
5150 -- Delete this log from the spinner stack
52− logs <- liftIO $ atomicModifyIORef' stack $ \old -> (delete s old, concatStack mark old)
53− logMessage $ Output_Overwrite [logs, "\n"]
51+ logs <- liftIO $ atomicModifyIORef' stack $ \old -> (L.delete (TerminalString_Normal s) old, concatStack mark old)
52+ logMessage $ Output_Write logs
5453 spinner = coloredSpinner defaultSpinnerTheme
5554
5655-- | How nested spinner logs should be displayed
57−concatStack :: String -> [Text] -> String
58−concatStack mark = drop 1 . foldr flatten "" . zip (mark : repeat arrow) . fmap T.unpack
59− where flatten (m, s) acc = unwords [acc, m, s]
60− arrow = withColor Blue "⇾"
56+concatStack :: TerminalString -> [TerminalString] -> [TerminalString]
57+concatStack mark = L.intersperse space . go . L.reverse
58+ where
59+ go [] = []
60+ go (x:[]) = mark : [x]
61+ go (x:xs) = arrow : x : go xs
62+ arrow = TerminalString_Colorized Blue "⇾"
63+ space = TerminalString_Normal " "
6164
6265-- | A spinner is simply an infinite list of strings that supplant each other in a delayed loop, creating the
6366-- animation of a "spinner".
64−type Spinner = [String]
65−
66−defaultSpinner :: SpinnerTheme -> Spinner
67−defaultSpinner = cycle
67+type Spinner = [TerminalString]
6868
6969coloredSpinner :: SpinnerTheme -> Spinner
70−coloredSpinner = defaultSpinner . fmap (withColor Cyan)
70+coloredSpinner = cycle . fmap (TerminalString_Colorized Cyan)
7171
7272-- | Run a spinner with a monadic function that defines how to represent the individual spinner characters.
73−runSpinner :: MonadIO m => Spinner -> (String -> m ()) -> m ()
73+runSpinner :: MonadIO m => Spinner -> (TerminalString -> m ()) -> m ()
7474runSpinner spinner f = forM_ spinner $ f >=> const delay
7575 where
7676 delay = liftIO $ threadDelay 100000 -- A shorter delay ensures that we update promptly.
7777
78−type SpinnerTheme = [String]
78+type SpinnerTheme = [Text]
7979
8080-- Find more spinners at https://github.com/sindresorhus/cli-spinners/blob/master/spinners.json
8181spinnerCircleHalves :: SpinnerTheme
@@ -91,14 +91,3 @@ bracket' acquire release use = mask $ \unmasked -> do
9191 result <- unmasked (use resource) `onException` release True resource
9292 _ <- release False resource
9393 return result
94−
95−withColor :: Color -> String -> String
96−withColor color s = mconcat
97− [ setSGRCode [SetColor Foreground Vivid color]
98− , s
99− , setSGRCode [Reset]
100− ]
101−
102−-- | Code for https://en.wikipedia.org/wiki/Enquiry_character
103−enquiryCode :: String
104−enquiryCode = "\ENQ"
lib/command/src/Obelisk/CLI/TerminalString.hsnew file+84
@@ -0,0 +1,84 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+-- | Types and functions dealing with strings to be printed on terminal.
5+module Obelisk.CLI.TerminalString
6+ ( TerminalString(..)
7+ , render
8+ , putStrWithSGR
9+ , getTerminalWidth
10+ , enquiryCode
11+ ) where
12+
13+import Control.Monad (when)
14+import Control.Monad.Catch (bracket_)
15+import Control.Monad.IO.Class (liftIO)
16+import Control.Monad.Reader (MonadIO)
17+import Data.Semigroup ((<>))
18+import Data.Text (Text)
19+import qualified Data.Text as T
20+import qualified Data.Text.IO as T
21+import System.Console.ANSI (Color, ColorIntensity (Vivid), ConsoleLayer (Foreground), SGR (Reset, SetColor),
22+ SGR, setSGR, setSGRCode)
23+import qualified System.Console.Terminal.Size as TerminalSize
24+
25+-- | Printable text on terminals
26+--
27+-- Represents text with an optional color code.
28+data TerminalString
29+ = TerminalString_Normal Text
30+ | TerminalString_Colorized Color Text
31+ deriving (Eq, Show, Ord)
32+
33+printableLength :: [TerminalString] -> Int
34+printableLength = T.length . toText False
35+
36+-- Render a list of TerminalString as Text that can be directly putStr'ed.
37+render
38+ :: Bool -- ^ with color
39+ -> Maybe Int -- ^ optionally, trim to maximum width
40+ -> [TerminalString]
41+ -> Text
42+render withColor w ts = trim w $ toText withColor ts
43+ where
44+ trim = \case
45+ Nothing -> id
46+ Just n -> \s -> if printableLength ts > n
47+ then T.take (n-3) s <> "..." <> T.pack resetCode
48+ else s
49+
50+toText :: Bool -> [TerminalString] -> Text
51+toText withColor = mconcat . map (toText' withColor)
52+
53+-- | Convert to Text, controlling whether colorization should happen.
54+toText' :: Bool -> TerminalString -> Text
55+toText' withColor = \case
56+ TerminalString_Normal s -> s
57+ TerminalString_Colorized c s -> if withColor then colorizeText c s else s
58+
59+-- | Colorize the given text so that it is printed in color when using putStr.
60+colorizeText :: Color -> Text -> Text
61+colorizeText color s = mconcat
62+ [ T.pack $ setSGRCode [SetColor Foreground Vivid color]
63+ , s
64+ , T.pack resetCode
65+ ]
66+
67+-- | Safely print the string with the given ANSI control codes, resetting in the end.
68+putStrWithSGR :: MonadIO m => [SGR] -> Bool -> Text -> m ()
69+putStrWithSGR sgr withNewLine s = liftIO $ bracket_ (setSGR sgr) reset $ T.putStr s
70+ where
71+ reset = setSGR [Reset] >> newline -- New line should come *after* reset (to reset cursor color).
72+ newline = when withNewLine $ T.putStrLn ""
73+
74+-- | Code for https://en.wikipedia.org/wiki/Enquiry_character
75+enquiryCode :: String
76+enquiryCode = "\ENQ"
77+
78+-- | Code to reset ANSI colors
79+resetCode :: String
80+resetCode = setSGRCode [Reset]
81+
82+getTerminalWidth :: IO (Maybe Int)
83+getTerminalWidth = fmap TerminalSize.width <$> TerminalSize.size
84+
lib/command/src/Obelisk/CLI/Types.hs+6−3
@@ -12,20 +12,23 @@ import Control.Monad.Reader (MonadIO, ReaderT (..), ask)
1212import Data.IORef (IORef)
1313import Data.Text (Text)
1414
15+import Obelisk.CLI.TerminalString (TerminalString)
16+
1517data CliConfig = CliConfig
1618 { _cliConfig_logLevel :: IORef Severity -- We are capable of changing the log level at runtime
1719 , _cliConfig_noColor :: Bool -- Disallow coloured output
1820 , _cliConfig_noSpinner :: Bool -- Disallow spinners
1921 , _cliConfig_lock :: MVar Bool -- Whether the last message was an Overwrite output
2022 , _cliConfig_tipDisplayed :: IORef Bool -- Whether the user tip (to make verbose) was already displayed
21− , _cliConfig_spinnerStack :: IORef [Text] -- Stack of logs from nested spinners
23+ , _cliConfig_spinnerStack :: IORef [TerminalString] -- Stack of logs from nested spinners
2224 }
2325
2426data Output
2527 = Output_Log (WithSeverity Text) -- Regular logging message (with colors and newlines)
2628 | Output_LogRaw (WithSeverity Text) -- Like `Output_Log` but without the implicit newline added.
27− | Output_Overwrite [String] -- Overwrites the current line (i.e. \r followed by `putStr`)
28− | Output_ClearLine -- Clears the line
29+ | Output_Write [TerminalString] -- Render and write a TerminalString using putstrLn
30+ | Output_Overwrite [TerminalString] -- Overwrite the current line (i.e. \r followed by `putStr`)
31+ | Output_ClearLine -- Clear the line
2932 deriving (Eq, Show, Ord)
3033
3134type Cli m = MonadLog Output m