console-style 0.0.1.1 → 0.0.2.0

raw patch · 2 files changed

+109/−78 lines, 2 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• console-style.cabal +1/−1
• src/System/Console/Style.hs +108/−77

@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           console-style-version:        0.0.1.1+version:        0.0.2.0 synopsis:       Styled console text output using ANSI escape sequences. description:    Styled console text output using ANSI escape sequences. category:       Text, User Interfaces, Monad

@@ -14,8 +14,8 @@ -- 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).+-- Warning: Windows support is currently not implemented, but+-- is planned (by using ansi-terminal or the ffi). -- -- Example: --@@ -49,11 +49,14 @@   hRunStyle,   hRunWithStyle,   runStyle,+  runStyleT,   runWithStyle,   setStyle,-  styleCode',-  styleCode,+  setStyleCode,   withStyle,+  changeStyle,+  applyStyle,+  applyStyleCode, ) where  import Data.Foldable (toList)@@ -64,9 +67,11 @@ import System.IO (Handle, stdout, hPutStr, hIsTerminalDevice) import System.Environment (getEnv) import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty +-- | Console color data Color-  = DefaultColor+  = DefaultColor                  -- ^ Default terminal color (terminal specific)   | Black   | Red   | Green@@ -83,31 +88,39 @@   | DullMagenta   | DullCyan   | DullWhite-  | Color256 !Word8-  | RGB      !Word8 !Word8 !Word8+  | Color256 !Word8               -- ^ Color from 256 color scheme. Color is automatically degraded to 8 colors for older terminals.+  | RGB      !Word8 !Word8 !Word8 -- ^ True color. Color is automatically degraded to 256 or 8 colors for older terminals.   deriving (Eq, Ord, Show) -data Term = TermDumb | Term8 | Term256 | TermRGB | TermWin+-- | Terminal type. For older terminals the style is automatically degraded.+data Term+  = TermDumb -- ^ Dumb terminal - no color output+  | Term8    -- ^ 8 colors supported+  | Term256  -- ^ 256 colors supported+  | TermRGB  -- ^ True colors supported+  | TermWin  -- ^ Windows terminal. Will use emulation (Not yet implemented).   deriving (Eq, Show) +-- | Style commands data SetStyle-  = Bold-  | NotBold-  | Italic-  | NotItalic-  | Under-  | NotUnder-  | Invert-  | NotInvert-  | Save-  | Restore-  | Reset-  | Blink-  | NotBlink+  = Bold           -- ^ Bold font+  | NotBold        -- ^ Normal-weight font+  | Italic         -- ^ Italic font+  | NotItalic      -- ^ Non-italic font+  | Under          -- ^ Underlined text+  | NotUnder       -- ^ Text without underline+  | Invert         -- ^ Invert foreground and background color+  | NotInvert      -- ^ Deactivate color inversion+  | Save           -- ^ Save style to stack+  | Restore        -- ^ Restore style from stack+  | Reset          -- ^ Reset to default style+  | Blink          -- ^ Activate blinking+  | NotBlink       -- ^ Deactivate blinking   | FgColor !Color   | BgColor !Color   deriving (Eq, Ord, Show) +-- | State accessor for the 'Style' class HasStyle s where   getStyle :: s -> Style   putStyle :: Style -> s -> s@@ -116,8 +129,11 @@   getStyle = id   putStyle = const +-- | Abstract state datatype which keeps+-- a stack of the applied styles. data Style = Style   { styleStack  :: !(NonEmpty StyleState)+  , styleActive :: !StyleState   , styleHandle :: !Handle   , styleTerm   :: !Term   }@@ -132,10 +148,10 @@   , styleBg     :: !Color   } deriving (Eq, Ord, Show) --- | The action @(hGetTerm handle)@ determines the terminal type of the file handle @handle@.+-- | The action @(hGetTerm handle)@ determines the terminal type of the file @handle@. -- -- The terminal type is determined by checking if the file handle points to a device--- and by looking at the $TERM environment variable.+-- and by looking at the @$TERM@ environment variable. hGetTerm :: MonadIO m => Handle -> m Term hGetTerm h = liftIO $ do   term <- hIsTerminalDevice h@@ -143,7 +159,7 @@     then envToTerm  <$> getEnv "TERM"     else pure TermDumb --- | Determine the terminal type from the value of the $TERM environment variable.+-- | Determine the terminal type from the value of the @$TERM@ environment variable. -- TODO improve this envToTerm :: String -> Term envToTerm "dumb" = TermDumb@@ -152,18 +168,19 @@                | otherwise = Term8   where rgbTerminals = ["xterm", "konsole", "gnome", "st", "linux"] --- | @(hDefaultStyle handle term) return the default (initial) style configured+-- | @(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.+-- Every 'Style' has a single associated handle. hDefaultStyle :: Handle -> Term -> Style hDefaultStyle h t = Style   { styleStack  = pure defaultStyleState   , styleHandle = h   , styleTerm   = t+  , styleActive = defaultStyleState   } --- | @(defaultStyle term)@ returns the default style configured with terminal type @term@.+-- | The function @(defaultStyle term)@ returns the default 'Style' configured with terminal type @term@. defaultStyle :: Term -> Style defaultStyle = hDefaultStyle stdout @@ -179,68 +196,46 @@   }  -- | The action @(hRunStyle handle action)@ runs the 'StateT' monad transformer providing--- the active style for the given @action@.+-- 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@.+-- the active 'Style' for the given @action@. runStyle :: Term -> State Style a -> a runStyle = flip evalState . defaultStyle +-- | The action @(runStyleT term action)@ runs the 'StateT' monad transformer providing+-- the active 'Style' for the given @action@.+runStyleT :: Monad m => Term -> StateT Style m a -> m a+runStyleT = flip evalStateT . defaultStyle+ -- | The action @(runWithStyle cmd action)@ runs the 'StateT' monad transformer providing--- the active style for the given @action@.+-- 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.+-- The output on 'stdout' within the @action@ is modified by the given 'StyleSet' 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 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.+-- The output on @handle@ within the @action@ is modified by the given 'StyleSet' 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-  let (style', str) = styleCode' style cmd-  modify $ putStyle style'-  pure str---- | 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 (styleHandle style) $ sgrCode style style'-  modify $ putStyle style'+hRunWithStyle h cmd action = hRunStyle h $ withStyle cmd action --- | The action @(withStyle cmd action)@ executes the @action@ with the current style modified--- by the style commands @cmd@.+-- | The action @(changeStyle cmd)@ modifies the active 'Style' by executing the 'StyleSet' commands @cmd@+-- without applying the changes. ----- 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-  setStyle [Restore]-  pure ret--updateStyle :: Foldable f => f SetStyle -> Style -> Style-updateStyle cmd (Style stack h t) = Style (foldl go stack cmd) h t-  where go (_:|(x:xs)) Restore     = x :| xs+-- You have to call applyStyle or applyStyleCode afterwards!+changeStyle :: (MonadState s m, HasStyle s, Foldable f) => f SetStyle -> m ()+changeStyle cmd = do+  style <- gets getStyle+  modify $ putStyle $ new style+  where new style = style { styleStack = foldl go (styleStack style) cmd }+        go (_:|(x:xs)) Restore     = x :| xs         go (_:|[])     Restore     = pure defaultStyleState         go (x:|xs)     Save        = x :| (x:xs)         go (_:|xs)     Reset       = defaultStyleState :| xs@@ -257,6 +252,41 @@         go (x:|xs)     (BgColor c) = x { styleBg     = c     } :| xs         go (x:|xs)     (FgColor c) = x { styleFg     = c     } :| xs +-- | The action @applyStyle@ applies the latest style changes.+applyStyle :: (MonadIO m, MonadState s m, HasStyle s) => m ()+applyStyle = do+  h <- gets (styleHandle . getStyle)+  applyStyleCode >>= liftIO . hPutStr h++-- | The action @applyStyleCode@ returns the ANSI code for the latest style changes.+applyStyleCode :: (MonadState s m, HasStyle s) => m String+applyStyleCode = do+  style <- gets getStyle+  let style' = style { styleActive = NonEmpty.head $ styleStack style }+  modify $ putStyle style'+  pure $ sgrCode (styleTerm style) (styleActive style) (styleActive style')++-- | The action @(styleCode cmd)@ returns the ANSI code corresponding to the 'StyleSet' commands @cmd@.+setStyleCode :: (MonadState s m, HasStyle s, Foldable f) => f SetStyle -> m String+setStyleCode cmd = changeStyle cmd >> applyStyleCode++-- | The action @(setStyle cmd)@ modifies the active 'Style' by executing the 'StyleSet' commands @cmd@.+--+-- The style changes are applied immediately.+setStyle :: (MonadIO m, MonadState s m, HasStyle s, Foldable f) => f SetStyle -> m ()+setStyle cmd = changeStyle cmd >> applyStyle++-- | The action @(withStyle cmd action)@ executes the @action@ with the active 'Style' modified+-- by the 'StyleSet' commands @cmd@.+--+-- The style is restored to the previous '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+  setStyle [Restore]+  pure ret+ reduceColor :: Term -> Color -> Color reduceColor Term8    = reduceColor8 reduceColor Term256  = reduceColor256@@ -321,11 +351,12 @@ csi :: Char -> [Word8] -> String csi cmd args = "\ESC[" ++ intercalate ";" (map show args) ++ pure cmd -sgrCode :: Style -> Style -> String-sgrCode (Style _ _ TermDumb) _ = ""-sgrCode (Style _ _ TermWin)  _ = ""-sgrCode (Style (old:|_) _ t) (Style (new:|_) _ _)-  | old /= new && new == defaultStyleState = csi 'm' [0]+sgrCode :: Term -> StyleState -> StyleState -> String+sgrCode TermDumb _ _ = ""+sgrCode TermWin  _ _ = ""+sgrCode t old new+  | old == new = ""+  | new == defaultStyleState = csi 'm' []   | otherwise = csi 'm' $     flag   styleBlink  5  ++     flag   styleBold   1  ++