console-style 0.0.1.0 → 0.0.1.1

raw patch · 2 files changed

+98/−68 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 +2/−2
• src/System/Console/Style.hs +96/−66

@@ -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

@@ -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 -- <https://raw.githubusercontent.com/minad/console-style/master/Example.hs Example.hs> 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]