wl-pprint-terminfo 0.1 → 0.1.1

raw patch · 2 files changed

+46/−9 lines, 2 files

Files

• System/Console/Terminfo/PrettyPrint.hs +45/−8
• wl-pprint-terminfo.cabal +1/−1

@@ -9,6 +9,17 @@   , protected   , invisible   , dim+  , red+  , black+  , green+  , blue+  , yellow+  , magenta+  , cyan+  , white+  -- * Color Pretty Printer+  , displayDoc+     , soft   , foreground   , background@@ -16,13 +27,13 @@   , ring   , evalTermState   , displayCap-  , displayDoc   ) where  import Text.PrettyPrint.Leijen.Extras import System.Console.Terminfo.Color import System.Console.Terminfo.Effects import System.Console.Terminfo.Base+import System.Console.Terminfo.Cursor import Data.Traversable import Control.Applicative import Control.Monad@@ -46,6 +57,7 @@   Colour (ColorNumber n) == Colour (ColorNumber m) = n == m   _ == _ = False + data PushCommand  = Bold  | Standout@@ -110,11 +122,14 @@   flip mplus (replay ts') $ case ts of      Standout:_  -> lift exitStandoutMode     Underline:_ -> lift exitUnderlineMode+    Nop:_       -> return mempty     _           -> mzero   where     replay xs = do       l <- lift allAttributesOff +     s <- get      r <- foldr (<#>) mempty <$> traverse (eval . Push) (reverse xs)+     put s      return $ l <#> r  tryTerm :: MonadPlus m => m TermOutput -> m TermOutput@@ -126,7 +141,13 @@ soft :: PushCommand -> PushCommand soft l = Else l Nop -blink, bold, underline, standout, reversed, protected, invisible, dim :: Doc Command -> Doc Command+foreground, background :: Color -> Doc Command -> Doc Command+foreground n = with (soft (Foreground (Colour n)))+background n = with (soft (Background (Colour n)))++red, black, green, yellow, blue, cyan, white, blink, bold, underline, + standout, reversed, protected, invisible, dim :: Doc Command -> Doc Command+ blink      = with (soft Blink) bold       = with (soft Bold) underline  = with (soft Underline)@@ -135,10 +156,16 @@ invisible  = with (soft Invisible) dim        = with (soft Dim)  standout   = with (soft Standout)-foreground, background :: Color -> Doc Command -> Doc Command-foreground n = with (soft (Foreground (Colour n)))-background n = with (soft (Background (Colour n))) +red = foreground Red+black = foreground Black+green = foreground Green+yellow = foreground Yellow+blue = foreground Blue+magenta = foreground Magenta+cyan = foreground Cyan+white = foreground White+ displayCap :: SimpleDoc Command -> StateT TermState Capability TermOutput displayCap = go where   go SEmpty        = return mempty@@ -163,10 +190,20 @@ displayDoc :: Float -> Doc Command -> IO () displayDoc ribbon doc = do     term <- setupTermFromEnv-    cols <- kludgeWindowSize `mplus` return 80-    let sdoc = renderPretty ribbon cols doc-    colored term sdoc `mplus` displayIO stdout sdoc+    displayDoc' term ribbon doc++displayDoc' :: Terminal -> Float -> Doc Command -> IO ()+displayDoc' term ribbon doc = do+ cols <- kludgeWindowSize `mplus` +         return (maybe 80 id (getCapability term termColumns))+ displayDoc'' term ribbon cols doc++displayDoc'' :: Terminal -> Float -> Int -> Doc Command -> IO ()+displayDoc'' term ribbon cols doc = colored term sdoc +                            `mplus` displayIO stdout sdoc   where +    sdoc = renderPretty ribbon cols doc     colored term sdoc = case getCapability term $ evalTermState $ displayCap sdoc of       Just output -> runTermOutput term output       Nothing     -> throwIO $ AssertionFailed "missing capability" -- TODO: downgrade+  

@@ -1,6 +1,6 @@ name:          wl-pprint-terminfo category:      Control, Monads, Text-version:       0.1+version:       0.1.1 cabal-version: >= 1.6 license:       BSD3 license-file:  LICENSE