colorful-monoids 0.1.0.1 → 0.2.0.0

raw patch · 6 files changed

+126/−94 lines, 6 filesdep −semigroupsPVP ok

version bump matches the API change (PVP)

Dependencies removed: semigroups

API changes (from Hackage documentation)

Files

• colorful-monoids.cabal +1/−7
• src/Data/Monoid/Colorful.hs +12/−5
• src/Data/Monoid/Colorful/Flat.hs +44/−24
• src/Data/Monoid/Colorful/Nested.hs +3/−3
• src/Data/Monoid/Colorful/SGR.hs +39/−34
• src/Data/Monoid/Colorful/Settings.hs +27/−21

@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           colorful-monoids-version:        0.1.0.1+version:        0.2.0.0 synopsis:       Styled console text output using ANSI escape sequences. description:    Styled console text output using ANSI escape sequences. category:       Text, User Interfaces, Monad@@ -29,9 +29,6 @@   ghc-options: -Wall   build-depends:       base >= 4.8 && < 5-  if impl(ghc < 8.0)-    build-depends:-        semigroups >= 0.9 && < 1   exposed-modules:       Data.Monoid.Colorful       Data.Monoid.Colorful.Flat@@ -52,7 +49,4 @@   build-depends:       base >= 4.8 && < 5     , colorful-monoids-  if impl(ghc < 8.0)-    build-depends:-        semigroups >= 0.9 && < 1   default-language: Haskell2010

@@ -9,11 +9,18 @@ -- Portability :  portable -- -- This library provides styled text output using ANSI--- escape sequences. The main feature is that the library--- 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.+-- escape sequences. The colored text is modeled+-- as nested Colored values, which form a Monoid.+-- As a result the colored code has a relatively concise form. --+-- For rendering, the Colored Monoid is flattended and+-- then printed out. The library keeps track of a stack of the active+-- styles internally, such that correct and minimal escape sequences are generated.+--+-- This library is used by+-- <https://hackage.haskell.org/package/wl-pprint-console wl-pprint-console>,+-- which is a pretty printer with support for annotations.+-- -- Warning: Windows support is currently not implemented, but -- is planned (by using ansi-terminal or the ffi). --@@ -53,7 +60,7 @@    -- ** Show with ANSI escape sequences   , showColored-  , showColoredA+  , showColoredM   , showColoredS    -- * Reexport from Data.Semigroup

@@ -20,6 +20,7 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE BangPatterns #-}  module Data.Monoid.Colorful.Flat (   -- * Colored datatypes@@ -42,7 +43,7 @@    -- ** Show with ANSI escape sequences   , showColored-  , showColoredA+  , showColoredM   , showColoredS    -- * Reexport from Data.Semigroup@@ -55,9 +56,9 @@ import Data.Monoid.Colorful.Color import Data.Monoid.Colorful.SGR import Data.Functor.Identity-import Data.Bifunctor (first, second) import GHC.Generics (Generic, Generic1) import Data.Semigroup ((<>))+import Data.Foldable (foldlM)  data Colored a   = Value a@@ -71,38 +72,57 @@   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Generic1)  hPrintColoredIO :: Handle -> Term -> [Colored (IO ())] -> IO ()-hPrintColoredIO h = showColoredA id (hPutStr h)+hPrintColoredIO h = showColoredM id (hPutStr h)  printColoredIO :: Term -> [Colored (IO ())] -> IO () printColoredIO = hPrintColoredIO stdout -hPrintColored :: (Handle -> a -> IO ()) -> Handle -> Term -> [Colored a] -> IO ()-hPrintColored f h = showColoredA (f h) (hPutStr h)+hPrintColored :: Foldable f => (Handle -> a -> IO ()) -> Handle -> Term -> f (Colored a) -> IO ()+hPrintColored f h = showColoredM (f h) (hPutStr h) -printColored :: (a -> IO ()) -> Term -> [Colored a] -> IO ()+printColored :: Foldable f => (a -> IO ()) -> Term -> f (Colored a) -> IO () printColored f = hPrintColored (const f) stdout -hPrintColoredS :: Handle -> Term -> [Colored String] -> IO ()-hPrintColoredS h = showColoredA (hPutStr h) (hPutStr h)+hPrintColoredS :: Foldable f => Handle -> Term -> f (Colored String) -> IO ()+hPrintColoredS h = showColoredM (hPutStr h) (hPutStr h) -printColoredS :: Term -> [Colored String] -> IO ()+printColoredS :: Foldable f => Term -> f (Colored String) -> IO () printColoredS = hPrintColoredS stdout -showColoredS :: Term -> [Colored String] -> ShowS+showColoredS :: Foldable f => Term -> f (Colored String) -> ShowS showColoredS = showColored (++) (++) -showColored :: Monoid o => (a -> o) -> (SGRCode -> o) -> Term -> [Colored a] -> o-showColored str code term flat = runIdentity $ showColoredA (pure . str) (pure . code) term flat+showColored :: (Foldable f, Monoid o) => (a -> o) -> (SGRCode -> o) -> Term -> f (Colored a) -> o+showColored str code term flat = runIdentity $ showColoredM (pure . str) (pure . code) term flat+{-# SPECIALIZE showColored :: Monoid o => (a -> o) -> (SGRCode -> o) -> Term -> [Colored a] -> o #-} -showColoredA :: (Applicative f, Monoid o) => (a -> f o) -> (SGRCode -> f o) -> Term -> [Colored a] -> f o-showColoredA str code term = go (defaultSettings, (defaultSettings, []))-  where go s (Style   a:b) = go ((second.first) (setStyle a True) s) b-        go s (Unstyle a:b) = go ((second.first) (setStyle a False) s) b-        go s (Fg      a:b) = go ((second.first) (setFg a) s) b-        go s (Bg      a:b) = go ((second.first) (setBg a) s) b-        go s (Push     :b) = go (second pushStack s) b-        go s (Pop      :b) = go (second popStack s) b-        go s (Reset    :b) = go (second resetStack s) b-        go s (Value   a:b) = let (old, stack@(new, _)) = s in-          mappend <$> (mappend <$> code (sgrCode term old new) <*> str a) <*> go (new, stack) b-        go s [] = let (old, (new, _)) = s in code (sgrCode term old new)+showColoredM :: (Foldable f, Monad m, Monoid o) => (a -> m o) -> (SGRCode -> m o) -> Term -> f (Colored a) -> m o+showColoredM str code term list = do+  s <- foldlM go (State mempty defaultSettings (defaultSettings, [])) list+  mappend (stateStr s) <$> code (sgrCode term (stateActive s) (fst $ stateStack s))+  where go s Push        = pure $ s { stateStack = pushStack $ stateStack s }+        go s Pop         = pure $ s { stateStack = popStack $ stateStack s }+        go s Reset       = pure $ s { stateStack = resetStack $ stateStack s }+        go s (Style   a) = pure $ mapTop (setStyle a True) s+        go s (Unstyle a) = pure $ mapTop (setStyle a False) s+        go s (Fg      a) = pure $ mapTop (setFg a) s+        go s (Bg      a) = pure $ mapTop (setBg a) s+        go s (Value   a) = do+          !x <- code (sgrCode term (stateActive s) (fst $ stateStack s))+          !y <- str a+          let !z = x `mappend` y+          pure $ s { stateStr = stateStr s `mappend` z, stateActive = fst $ stateStack s }+{-# SPECIALIZE showColoredM :: (Foldable f, Monoid o) => (a -> Identity o) -> (SGRCode -> Identity o) -> Term -> f (Colored a) -> Identity o #-}+{-# SPECIALIZE showColoredM :: (Foldable f, Monoid o) => (a -> (o -> o)) -> (SGRCode -> (o -> o)) -> Term -> f (Colored a) -> (o -> o) #-}+{-# SPECIALIZE showColoredM :: Monoid o => (a -> Identity o) -> (SGRCode -> Identity o) -> Term -> [Colored a] -> Identity o #-}+{-# SPECIALIZE showColoredM :: Monoid o => (a -> (o -> o)) -> (SGRCode -> (o -> o)) -> Term -> [Colored a] -> (o -> o) #-}++data State a = State+  { stateStr  :: !a+  , stateActive :: !Settings+  , stateStack  :: !(Settings, [Settings])+  }++mapTop :: (Settings -> Settings) -> State a -> State a+mapTop f s = let !t = f $ fst $ stateStack s in s { stateStack = (t, snd $ stateStack s) }+{-# INLINE mapTop #-}

@@ -18,7 +18,7 @@   , hPrintColoredS   , printColoredS   , showColored-  , showColoredA+  , showColoredM   , showColoredS ) where @@ -103,8 +103,8 @@ printColoredS :: Term -> Colored String -> IO () printColoredS t = Flat.printColoredS t . flatten -showColoredA :: (Applicative f, Monoid o) => (a -> f o) -> (SGRCode -> f o) -> Term -> Colored a -> f o-showColoredA f g t = Flat.showColoredA f g t . flatten+showColoredM :: (Monad f, Monoid o) => (a -> f o) -> (SGRCode -> f o) -> Term -> Colored a -> f o+showColoredM f g t = Flat.showColoredM f g t . flatten  showColored :: Monoid o => (a -> o) -> (SGRCode -> o) -> Term -> Colored a -> o showColored f g t = Flat.showColored f g t . flatten

@@ -7,14 +7,16 @@ import Data.Monoid.Colorful.Settings import Data.Monoid.Colorful.Color import Data.Word (Word8)-import Data.List.NonEmpty (NonEmpty(..)) import Data.Bool (bool)-import Data.List (intercalate)  type SGRCode = String  csi :: Char -> [Word8] -> SGRCode-csi cmd args = "\ESC[" ++ intercalate ";" (map show args) ++ pure cmd+csi cmd args = (("\ESC["++) . go args) [cmd]+  where go [] = id+        go [x] = (show x++)+        go (x:xs@(_:_)) = (show x++) . (';':) . go xs+{-# INLINE csi #-}  sgrCode :: Term -> Settings -> Settings -> SGRCode sgrCode TermDumb _ _ = ""@@ -23,39 +25,42 @@   | old == new = ""   | new == defaultSettings = csi 'm' []   | otherwise = csi 'm' $-    flag  styleBlink  5  ++-    flag  styleBold   1  ++-    flag  styleItalic 3  ++-    flag  styleUnder  4  ++-    flag  styleInvert 7  ++-    color styleFg     0  ++-    color styleBg     10+                (flag  settingBlink  5 .+                 flag  settingBold   1 .+                 flag  settingItalic 3 .+                 flag  settingUnder  4 .+                 flag  settingInvert 7 .+                 color settingFg     0 .+                 color settingBg     10) []    where -  update :: Eq a => (Settings -> a) -> (a -> [Word8]) -> [Word8]-  update f g = let new' = f new in bool [] (g new') (new' /= f old)+  update :: Eq a => (Settings -> a) -> (a -> ([Word8] -> [Word8])) -> ([Word8] -> [Word8])+  update f g = let new' = f new in bool id (g new') (new' /= f old) -  flag  f n = update f $ bool [20 + n] [n]-  color f n = update (reduceColor t . f) (\x -> let (c:|cs) = sgrColorArgs x in c + n : cs)+  flag  f n = update f $ bool (20 + n:) (n:)+  color f n = update (reduceColor t . f) $ sgrColorArgs n+{-# INLINE sgrCode #-} -sgrColorArgs :: Color -> NonEmpty Word8-sgrColorArgs (Color256 n) = 38 :| [5, n]-sgrColorArgs (RGB r g b)  = 38 :| [2, r, g, b]-sgrColorArgs Black        = pure 90-sgrColorArgs Red          = pure 91-sgrColorArgs Green        = pure 92-sgrColorArgs Yellow       = pure 93-sgrColorArgs Blue         = pure 94-sgrColorArgs Magenta      = pure 95-sgrColorArgs Cyan         = pure 96-sgrColorArgs White        = pure 97-sgrColorArgs DullBlack    = pure 30-sgrColorArgs DullRed      = pure 31-sgrColorArgs DullGreen    = pure 32-sgrColorArgs DullYellow   = pure 33-sgrColorArgs DullBlue     = pure 34-sgrColorArgs DullMagenta  = pure 35-sgrColorArgs DullCyan     = pure 36-sgrColorArgs DullWhite    = pure 37-sgrColorArgs DefaultColor = pure 39+sgrColorArgs :: Word8 -> Color -> ([Word8] -> [Word8])+sgrColorArgs n c = case c of+  (Color256 o) -> ([38 + n, 5, o]++)+  (RGB r g b)  -> ([38 + n, 2, r, g, b]++)+  Black        -> (90 + n:)+  Red          -> (91 + n:)+  Green        -> (92 + n:)+  Yellow       -> (93 + n:)+  Blue         -> (94 + n:)+  Magenta      -> (95 + n:)+  Cyan         -> (96 + n:)+  White        -> (97 + n:)+  DullBlack    -> (30 + n:)+  DullRed      -> (31 + n:)+  DullGreen    -> (32 + n:)+  DullYellow   -> (33 + n:)+  DullBlue     -> (34 + n:)+  DullMagenta  -> (35 + n:)+  DullCyan     -> (36 + n:)+  DullWhite    -> (37 + n:)+  DefaultColor -> (39 + n:)+{-# INLINE sgrColorArgs #-}

@@ -8,41 +8,47 @@ import Data.Monoid.Colorful.Color  data Settings = Settings-  { styleBold   :: !Bool-  , styleItalic :: !Bool-  , styleUnder  :: !Bool-  , styleInvert :: !Bool-  , styleBlink  :: !Bool-  , styleFg     :: !Color-  , styleBg     :: !Color+  { settingBold   :: !Bool+  , settingItalic :: !Bool+  , settingUnder  :: !Bool+  , settingInvert :: !Bool+  , settingBlink  :: !Bool+  , settingFg     :: !Color+  , settingBg     :: !Color   } deriving (Eq)  type SettingsStack = (Settings, [Settings])  defaultSettings :: Settings defaultSettings = Settings-  { styleBold   = False-  , styleItalic = False-  , styleInvert = False-  , styleUnder  = False-  , styleBlink  = False-  , styleFg     = DefaultColor-  , styleBg     = DefaultColor+  { settingBold   = False+  , settingItalic = False+  , settingInvert = False+  , settingUnder  = False+  , settingBlink  = False+  , settingFg     = DefaultColor+  , settingBg     = DefaultColor   }  setStyle :: Style -> Bool -> Settings -> Settings-setStyle Bold   b s = s { styleBold   = b }-setStyle Italic b s = s { styleItalic = b }-setStyle Under  b s = s { styleUnder  = b }-setStyle Invert b s = s { styleInvert = b }-setStyle Blink  b s = s { styleBlink  = b }+setStyle Bold   b s = s { settingBold   = b }+setStyle Italic b s = s { settingItalic = b }+setStyle Under  b s = s { settingUnder  = b }+setStyle Invert b s = s { settingInvert = b }+setStyle Blink  b s = s { settingBlink  = b }+{-# INLINE setStyle #-}  setBg, setFg :: Color -> Settings -> Settings-setBg c s = s { styleBg = c }-setFg c s = s { styleFg = c }+setBg c s = s { settingBg = c }+setFg c s = s { settingFg = c }+{-# INLINE setBg #-}+{-# INLINE setFg #-}  resetStack, pushStack, popStack :: SettingsStack -> SettingsStack resetStack (_, ys)     = (defaultSettings, ys) pushStack  (y, ys)     = (y, y:ys) popStack   (_, [])     = (defaultSettings, []) popStack   (_, z : zs) = (z, zs)+{-# INLINE resetStack #-}+{-# INLINE pushStack #-}+{-# INLINE popStack #-}