wl-pprint-terminfo (empty) → 0.1

raw patch · 4 files changed

+235/−0 lines, 4 filesdep +basedep +hscursesdep +semigroupssetup-changed

Dependencies added: base, hscurses, semigroups, terminfo, transformers, wl-pprint-extras

Files

• LICENSE +27/−0
• Setup.lhs +3/−0
• System/Console/Terminfo/PrettyPrint.hs +172/−0
• wl-pprint-terminfo.cabal +33/−0

@@ -0,0 +1,27 @@+Copyright 2011, Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++  * Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.++  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in+    the documentation and/or other materials provided with the+    distribution.++This software is provided by the copyright holders "as is" and any+express or implied warranties, including, but not limited to, the+implied warranties of merchantability and fitness for a particular+purpose are disclaimed. In no event shall the copyright holders be+liable for any direct, indirect, incidental, special, exemplary, or+consequential damages (including, but not limited to, procurement of+substitute goods or services; loss of use, data, or profits; or+business interruption) however caused and on any theory of liability,+whether in contract, strict liability, or tort (including negligence+or otherwise) arising in any way out of the use of this software, even+if advised of the possibility of such damage.

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

@@ -0,0 +1,172 @@+module System.Console.Terminfo.PrettyPrint+  ( PushCommand(..)+  , with+  , blink+  , bold+  , underline+  , standout+  , reversed+  , protected+  , invisible+  , dim+  , soft+  , foreground+  , background+  , Bell(..)+  , 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 Data.Traversable+import Control.Applicative+import Control.Monad+import Control.Monad.Trans.State+import UI.HSCurses.Curses (initScr, scrSize, endWin)+import Control.Monad.Trans.Class+import Control.Exception (finally, throwIO, AssertionFailed(..))+import System.IO (stdout)++newtype Colour = Colour { color :: Color }++instance Eq Colour where+  Colour Black == Colour Black = True+  Colour Red == Colour Red = True+  Colour Green == Colour Green = True+  Colour Yellow == Colour Yellow = True+  Colour Blue == Colour Blue = True+  Colour Magenta == Colour Magenta = True+  Colour Cyan == Colour Cyan = True+  Colour White == Colour White = True+  Colour (ColorNumber n) == Colour (ColorNumber m) = n == m+  _ == _ = False++data PushCommand+ = Bold+ | Standout+ | Underline+ | Reverse+ | Blink+ | Dim+ | Invisible+ | Protected+ | Foreground Colour+ | Background Colour+ | Else PushCommand PushCommand+ | Nop+ deriving (Eq)++data Bell+  = VisibleBellOnly+  | AudibleBellOnly+  | VisibleBellPreferred+  | AudibleBellPreferred+  deriving (Eq,Ord,Show,Enum)++data Command +  = Push PushCommand+  | Pop+  | Ring Bell -- visual bell ok, audible bell ok, +  deriving (Eq)++type TermState = [PushCommand]++ring :: Bell -> Doc Command+ring b = pure (Ring b)++eval :: Command -> StateT TermState Capability TermOutput+eval (Push Blink)          = modify (Blink:) *> lift blinkOn+eval (Push Reverse)        = modify (Reverse:) *> lift reverseOn+eval (Push Protected)      = modify (Protected:) *> lift protectedOn+eval (Push Bold)           = modify (Bold:) *> lift boldOn+eval (Push (Foreground n)) = do+  modify (Foreground n:) +  f <- lift setForegroundColor+  return $ f $ color n+eval (Push (Background n)) = do+  modify (Background n:)+  f <- lift setBackgroundColor+  return $ f $ color n+eval (Push Invisible)      = modify (Invisible:) *> lift invisibleOn+eval (Push Dim)            = modify (Dim:) *> lift dimOn+eval (Push Underline)      = modify (Underline:) *> lift enterUnderlineMode+eval (Push Standout)       = modify (Standout:) *> lift enterStandoutMode+eval (Push Nop)            = modify (Nop:) *> return mempty+eval (Push (Else l r))     = eval (Push l) <|> eval (Push r)+eval (Ring b)              = case b of+  VisibleBellOnly  -> lift $ tryTerm visualBell+  AudibleBellOnly -> lift $ tryTerm bell+  VisibleBellPreferred -> lift $ visualBell `mplus` tryTerm bell+  AudibleBellPreferred -> lift $ bell `mplus` tryTerm visualBell+eval Pop = do +  ts <- get+  let ts' = drop 1 ts+  put ts'+  flip mplus (replay ts') $ case ts of +    Standout:_  -> lift exitStandoutMode+    Underline:_ -> lift exitUnderlineMode+    _           -> mzero+  where +   replay xs = do +     l <- lift allAttributesOff +     r <- foldr (<#>) mempty <$> traverse (eval . Push) (reverse xs)+     return $ l <#> r++tryTerm :: MonadPlus m => m TermOutput -> m TermOutput+tryTerm m = m `mplus` return mempty++with :: PushCommand -> Doc Command -> Doc Command+with cmd = pure (Push cmd) `enclose` pure Pop++soft :: PushCommand -> PushCommand+soft l = Else l Nop++blink, bold, underline, standout, reversed, protected, invisible, dim :: Doc Command -> Doc Command+blink      = with (soft Blink)+bold       = with (soft Bold)+underline  = with (soft Underline)+reversed   = with (soft Reverse)+protected  = with (soft Protected)+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)))++displayCap :: SimpleDoc Command -> StateT TermState Capability TermOutput+displayCap = go where+  go SEmpty        = return mempty+  go (SChar c x)   = (termText [c] <#>) <$> go x+  go (SText _ s x) = (termText s <#>) <$> go x+  go (SLine i x)   = (termText ('\n': spaces i) <#>) <$> go x+  go (SEffect e t) = (<#>) <$> eval e <*> go t+    +spaces :: Int -> String+spaces n | n <= 0    = ""+         | otherwise = replicate n ' '++evalTermState :: Monad m => StateT TermState m a -> m a+evalTermState s = liftM fst $ runStateT s []++kludgeWindowSize :: IO Int+kludgeWindowSize = do+   _ <- initScr+   snd <$> scrSize+ `finally` endWin++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+  where +    colored term sdoc = case getCapability term $ evalTermState $ displayCap sdoc of+      Just output -> runTermOutput term output+      Nothing     -> throwIO $ AssertionFailed "missing capability" -- TODO: downgrade

@@ -0,0 +1,33 @@+name:          wl-pprint-terminfo+category:      Control, Monads, Text+version:       0.1+cabal-version: >= 1.6+license:       BSD3+license-file:  LICENSE+author:        Edward A. Kmett+maintainer:    Edward A. Kmett <ekmett@gmail.com>+stability:     experimental+homepage:      git://github.com/ekmett/wl-pprint-terminfo/+copyright:     Copyright (C) 2011 Edward A. Kmett+synopsis:      A color pretty printer with terminfo support+description:   A color pretty printer with terminfo support+build-type:    Simple++source-repository head+  type: git+  location: git://github.com/ekmett/wl-pprint-terminfo.git++library++  build-depends: +    base >= 4 && < 5,+    semigroups >= 0.6 && < 0.7,+    wl-pprint-extras >= 1.2 && < 1.3,+    hscurses >= 1.4 && < 1.5,+    terminfo >= 0.3 && < 0.4,+    transformers >= 0.2.2 && < 0.3++  exposed-modules:+    System.Console.Terminfo.PrettyPrint++  ghc-options:      -Wall