diff --git a/console-style.cabal b/console-style.cabal --- a/console-style.cabal +++ b/console-style.cabal @@ -3,10 +3,10 @@ -- see: https://github.com/sol/hpack name: console-style -version: 0.0.1.0 +version: 0.0.1.1 synopsis: Styled console text output using ANSI escape sequences. description: Styled console text output using ANSI escape sequences. -category: Text +category: Text, User Interfaces, Monad stability: experimental homepage: https://github.com/minad/console-style#readme bug-reports: https://github.com/minad/console-style/issues diff --git a/src/System/Console/Style.hs b/src/System/Console/Style.hs --- a/src/System/Console/Style.hs +++ b/src/System/Console/Style.hs @@ -10,10 +10,13 @@ -- -- This library provides styled text output using ANSI -- escape sequences. The main feature is that the library --- keeps track of a stack of the applied styles using a state monad. +-- keeps track of a stack of the active styles using a state monad. -- This makes it easy to use this library for a pretty printer with -- nested annotations, e.g., wl-pprint-console. -- +-- Warning: Windows supports is currently not implemented, but +-- is planned (by using ansi-terminal or by directly using the ffi). +-- -- Example: -- -- > basicExample :: IO () @@ -30,25 +33,22 @@ -- > -- > liftIO $ putStrLn "Normal output" -- --- For many more examples, see the project's extensive +-- For many more examples, see the -- file. ----------------------------------------------------------- module System.Console.Style ( - Blink(..), Color(..), HasStyle(..), SetStyle(..), Style, - StyleT, Term(..), defaultStyle, + hDefaultStyle, hGetTerm, + hRunStyle, hRunWithStyle, - hSetStyle, - hWithStyle, runStyle, - runStyleT, runWithStyle, setStyle, styleCode', @@ -59,7 +59,7 @@ import Data.Foldable (toList) import Data.Word import Data.Bool (bool) -import Data.List (intercalate) +import Data.List (intercalate, isPrefixOf, isInfixOf) import Control.Monad.State.Strict import System.IO (Handle, stdout, hPutStr, hIsTerminalDevice) import System.Environment (getEnv) @@ -87,9 +87,6 @@ | RGB !Word8 !Word8 !Word8 deriving (Eq, Ord, Show) -data Blink = NoBlink | BlinkSlow | BlinkFast - deriving (Eq, Ord, Show) - data Term = TermDumb | Term8 | Term256 | TermRGB | TermWin deriving (Eq, Show) @@ -105,7 +102,8 @@ | Save | Restore | Reset - | Blink !Blink + | Blink + | NotBlink | FgColor !Color | BgColor !Color deriving (Eq, Ord, Show) @@ -118,35 +116,56 @@ getStyle = id putStyle = const -data Style = Style !(NonEmpty StyleState) !Term - -type StyleT = StateT Style +data Style = Style + { styleStack :: !(NonEmpty StyleState) + , styleHandle :: !Handle + , styleTerm :: !Term + } data StyleState = StyleState { styleBold :: !Bool , styleItalic :: !Bool , styleUnder :: !Bool , styleInvert :: !Bool - , styleBlink :: !Blink + , styleBlink :: !Bool , styleFg :: !Color , styleBg :: !Color } deriving (Eq, Ord, Show) +-- | The action @(hGetTerm handle)@ determines the terminal type of the file handle @handle@. +-- +-- The terminal type is determined by checking if the file handle points to a device +-- and by looking at the $TERM environment variable. hGetTerm :: MonadIO m => Handle -> m Term -hGetTerm handle = liftIO $ do - term <- hIsTerminalDevice handle +hGetTerm h = liftIO $ do + term <- hIsTerminalDevice h if term then envToTerm <$> getEnv "TERM" else pure TermDumb +-- | Determine the terminal type from the value of the $TERM environment variable. -- TODO improve this envToTerm :: String -> Term -envToTerm "xterm" = TermRGB -envToTerm "dumb" = TermDumb -envToTerm _ = TermRGB +envToTerm "dumb" = TermDumb +envToTerm term | any (flip isPrefixOf term) rgbTerminals = TermRGB + | "256" `isInfixOf` term = Term256 + | otherwise = Term8 + where rgbTerminals = ["xterm", "konsole", "gnome", "st", "linux"] +-- | @(hDefaultStyle handle term) return the default (initial) style configured +-- with the file handle @handle@ and terminal type @term@. +-- +-- Every style has a single associated handle. +hDefaultStyle :: Handle -> Term -> Style +hDefaultStyle h t = Style + { styleStack = pure defaultStyleState + , styleHandle = h + , styleTerm = t + } + +-- | @(defaultStyle term)@ returns the default style configured with terminal type @term@. defaultStyle :: Term -> Style -defaultStyle = Style $ pure defaultStyleState +defaultStyle = hDefaultStyle stdout defaultStyleState :: StyleState defaultStyleState = StyleState @@ -154,29 +173,45 @@ , styleItalic = False , styleInvert = False , styleUnder = False - , styleBlink = NoBlink + , styleBlink = False , styleFg = DefaultColor , styleBg = DefaultColor } -runStyleT :: Monad m => Term -> StyleT m a -> m a -runStyleT = flip evalStateT . defaultStyle +-- | The action @(hRunStyle handle action)@ runs the 'StateT' monad transformer providing +-- the active style for the given @action@. +hRunStyle :: MonadIO m => Handle -> StateT Style m a -> m a +hRunStyle h x = hDefaultStyle h <$> hGetTerm h >>= evalStateT x +-- | The action @(runStyle term action)@ runs the 'State' monad providing +-- the active style for the given @action@. runStyle :: Term -> State Style a -> a runStyle = flip evalState . defaultStyle -hRunWithStyle :: MonadIO m => Handle -> [SetStyle] -> StyleT m a -> m a -hRunWithStyle handle style action = do - term <- hGetTerm handle - runStyleT term $ hWithStyle handle style action - -runWithStyle :: MonadIO m => [SetStyle] -> StyleT m a -> m a +-- | The action @(runWithStyle cmd action)@ runs the 'StateT' monad transformer providing +-- the active style for the given @action@. +-- +-- The output on 'stdout' within the @action@ is modified by the given style commands @cmd@. +-- The style is restored to the defaults afterwards. +runWithStyle :: (MonadIO m, Foldable f) => f SetStyle -> StateT Style m a -> m a runWithStyle = hRunWithStyle stdout +-- | The action @(hRunWithStyle handle cmd action)@ runs the 'StateT' monad transformer providing +-- the active style for the given @action@. +-- +-- The output on @handle@ within the @action@ is modified by the given style commands @cmd@. +-- The style is restored to the defaults afterwards. +hRunWithStyle :: (MonadIO m, Foldable f) => Handle -> f SetStyle -> StateT Style m a -> m a +hRunWithStyle h style action = hRunStyle h $ withStyle style action + +-- | The function @(styleCode' style cmd)@ returns the modified style status and ANSI code +-- corresponding to the style commands @cmd@. styleCode' :: Foldable f => Style -> f SetStyle -> (Style, String) styleCode' style cmd = (style', sgrCode style style') where style' = updateStyle cmd style +-- | The action @(styleCode cmd)@ returns the ANSI code corresponding to the style commands @cmd@. +-- This action must be executed within a monadic context providing the current style status. styleCode :: (MonadState s m, HasStyle s, Foldable f) => f SetStyle -> m String styleCode cmd = do style <- gets getStyle @@ -184,43 +219,43 @@ modify $ putStyle style' pure str -hSetStyle :: (MonadIO m, MonadState s m, HasStyle s, Foldable f) => Handle -> f SetStyle -> m () -hSetStyle handle cmd = do +-- | The action @(setStyle cmd)@ modifies the current style by executing the style commands @cmd@. +setStyle :: (MonadIO m, MonadState s m, HasStyle s, Foldable f) => f SetStyle -> m () +setStyle cmd = do style <- gets getStyle let style' = updateStyle cmd style - liftIO $ hPutStr handle $ sgrCode style style' + liftIO $ hPutStr (styleHandle style) $ sgrCode style style' modify $ putStyle style' -hWithStyle :: (MonadIO m, MonadState s m, HasStyle s, Foldable f) => Handle -> f SetStyle -> m a -> m a -hWithStyle handle cmd action = do - hSetStyle handle (Save : toList cmd) +-- | The action @(withStyle cmd action)@ executes the @action@ with the current style modified +-- by the style commands @cmd@. +-- +-- The style is restored to the previously active style afterwards. +withStyle :: (MonadIO m, MonadState s m, HasStyle s, Foldable f) => f SetStyle -> m a -> m a +withStyle cmd action = do + setStyle (Save : toList cmd) ret <- action - hSetStyle handle [Restore] + setStyle [Restore] pure ret -withStyle :: (MonadIO m, MonadState s m, HasStyle s, Foldable f) => f SetStyle -> m a -> m a -withStyle = hWithStyle stdout - -setStyle :: (MonadIO m, MonadState s m, HasStyle s, Foldable f) => f SetStyle -> m () -setStyle = hSetStyle stdout - updateStyle :: Foldable f => f SetStyle -> Style -> Style -updateStyle cmd (Style stack term) = Style (foldl go stack cmd) term +updateStyle cmd (Style stack h t) = Style (foldl go stack cmd) h t where go (_:|(x:xs)) Restore = x :| xs go (_:|[]) Restore = pure defaultStyleState go (x:|xs) Save = x :| (x:xs) go (_:|xs) Reset = defaultStyleState :| xs go (x:|xs) Bold = x { styleBold = True } :| xs - go (x:|xs) Invert = x { styleInvert = True } :| xs - go (x:|xs) Italic = x { styleItalic = True } :| xs go (x:|xs) NotBold = x { styleBold = False } :| xs + go (x:|xs) Invert = x { styleInvert = True } :| xs go (x:|xs) NotInvert = x { styleInvert = False } :| xs + go (x:|xs) Italic = x { styleItalic = True } :| xs go (x:|xs) NotItalic = x { styleItalic = False } :| xs - go (x:|xs) NotUnder = x { styleUnder = False } :| xs go (x:|xs) Under = x { styleUnder = True } :| xs - go (x:|xs) (BgColor c) = x { styleBg = c } :| xs - go (x:|xs) (Blink b) = x { styleBlink = b } :| xs - go (x:|xs) (FgColor c) = x { styleFg = c } :| xs + go (x:|xs) NotUnder = x { styleUnder = False } :| xs + go (x:|xs) Blink = x { styleBlink = True } :| xs + go (x:|xs) NotBlink = x { styleBlink = False } :| xs + go (x:|xs) (BgColor c) = x { styleBg = c } :| xs + go (x:|xs) (FgColor c) = x { styleFg = c } :| xs reduceColor :: Term -> Color -> Color reduceColor Term8 = reduceColor8 @@ -287,17 +322,17 @@ csi cmd args = "\ESC[" ++ intercalate ";" (map show args) ++ pure cmd sgrCode :: Style -> Style -> String -sgrCode (Style _ TermDumb) _ = "" -sgrCode (Style _ TermWin) _ = "" -sgrCode (Style (old:|_) term) (Style (new:|_) _) +sgrCode (Style _ _ TermDumb) _ = "" +sgrCode (Style _ _ TermWin) _ = "" +sgrCode (Style (old:|_) _ t) (Style (new:|_) _ _) | old /= new && new == defaultStyleState = csi 'm' [0] | otherwise = csi 'm' $ - update styleBlink (pure . sgrBlinkArg) ++ - flag styleBold 1 ++ - flag styleItalic 3 ++ - flag styleUnder 4 ++ - flag styleInvert 7 ++ - color styleFg 0 ++ + flag styleBlink 5 ++ + flag styleBold 1 ++ + flag styleItalic 3 ++ + flag styleUnder 4 ++ + flag styleInvert 7 ++ + color styleFg 0 ++ color styleBg 10 where @@ -306,12 +341,7 @@ update f g = let new' = f new in bool [] (g new') (new' /= f old) flag f n = update f $ bool [20 + n] [n] - color f n = update (reduceColor term . f) (\x -> let (c:|cs) = sgrColorArgs x in c + n : cs) - -sgrBlinkArg :: Blink -> Word8 -sgrBlinkArg NoBlink = 25 -sgrBlinkArg BlinkSlow = 5 -sgrBlinkArg BlinkFast = 6 + color f n = update (reduceColor t . f) (\x -> let (c:|cs) = sgrColorArgs x in c + n : cs) sgrColorArgs :: Color -> NonEmpty Word8 sgrColorArgs (Color256 n) = 38 :| [5, n]