src/Darcs/ColorPrinter.lhs

   1 \begin{code}
   2 {-# OPTIONS -fno-warn-orphans #-}
   3 module Darcs.ColorPrinter ( errorDoc, traceDoc, assertDoc, fancyPrinters ) where
   4
   5 import Debug.Trace ( trace )
   6 import System.IO ( stderr )
   7 import Darcs.External (getTermNColors)
   8 import Printer (Printer, Printers, Printers'(..), Printable(..), Color(..),
   9                 invisiblePrinter, (<>), (<?>), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat,
  10                 unsafeText, unsafeChar, space, unsafePackedString,
  11                 renderStringWith, prefix )
  12 import Data.Char ( isAscii, isPrint, isSpace, isControl, ord, chr, intToDigit )
  13 import Data.Bits ( bit, xor )
  14 import System.Environment ( getEnv )
  15 import qualified Data.ByteString.Char8 as BC (unpack, any, last, spanEnd)
  16 import qualified Data.ByteString       as B (null, init)
  17 import System.IO.Unsafe ( unsafePerformIO )
  18 import System.IO ( hIsTerminalDevice, Handle )
  19
  20 dollar, cr :: Doc
  21 dollar = unsafeBothText "$"
  22 cr     = unsafeBothText "\r"
  23
  24 errorDoc :: Doc -> a
  25 errorDoc = error . show
  26
  27 traceDoc :: Doc -> a -> a
  28 traceDoc d = trace (show d)
  29
  30 assertDoc :: Maybe Doc -> a -> a
  31 assertDoc Nothing x = x
  32 assertDoc (Just e) _ = errorDoc e
  33
  34 instance Show Doc where
  35     show = renderStringWith (fancyPrinters stderr)
  36
  37 -- policy
  38 -- | the 'Policy' type is a record containing the variables which control
  39 -- how 'Doc's will be rendered on some output.
  40 data Policy = Policy { poColor :: Bool    -- ^ overall use of color
  41                      , poEscape :: Bool   -- ^ overall use of escaping
  42                      , poLineColor :: Bool -- ^ overall use of colored lines (only hunks for now)
  43                      , poAltColor :: Bool -- ^ alternative to color (bold, inverse)
  44                      , poIsprint :: Bool  -- ^ don't escape isprints
  45                      , po8bit  :: Bool    -- ^ don't escape 8-bit chars
  46                      , poNoEscX :: String   -- ^ extra chars to never escape
  47                      , poEscX :: String   -- ^ extra chars to always escape
  48                      , poTrailing :: Bool -- ^ escape trailing spaces
  49                      , poCR :: Bool       -- ^ ignore \r at end of lines
  50                      , poSpace :: Bool    -- ^ escape spaces (used with poTrailing)
  51                      }
  52
  53 {-# NOINLINE getPolicy #-}
  54 -- | 'getPolicy' returns a suitable policy for a given handle.
  55 -- The policy is chosen according to environment variables, and to the
  56 -- type of terminal which the handle represents
  57 getPolicy :: Handle -> Policy
  58 getPolicy handle = unsafePerformIO $
  59  do isTerminal <- hIsTerminalDevice handle
  60     nColors <- if isTerminal then getTermNColors else return 0
  61
  62     envDontEscapeAnything  <- getEnvBool "DARCS_DONT_ESCAPE_ANYTHING"
  63     envDontEscapeIsprint   <- getEnvBool "DARCS_DONT_ESCAPE_ISPRINT"
  64     envUseIsprint          <- getEnvBool "DARCS_USE_ISPRINT" -- for backwards-compatibility
  65     envDontEscape8bit      <- getEnvBool "DARCS_DONT_ESCAPE_8BIT"
  66
  67     envDontEscapeExtra  <- getEnvString "DARCS_DONT_ESCAPE_EXTRA"
  68     envEscapeExtra      <- getEnvString "DARCS_ESCAPE_EXTRA"
  69
  70     envDontEscapeTrailingSpace  <- getEnvBool "DARCS_DONT_ESCAPE_TRAILING_SPACES"
  71     envDontEscapeTrailingCR     <- getEnvBool "DARCS_DONT_ESCAPE_TRAILING_CR"
  72
  73     envDontColor         <- getEnvBool "DARCS_DONT_COLOR"
  74     envAlwaysColor       <- getEnvBool "DARCS_ALWAYS_COLOR"
  75     envAlternativeColor  <- getEnvBool "DARCS_ALTERNATIVE_COLOR"
  76     envDoColorLines    <- getEnvBool "DARCS_DO_COLOR_LINES"
  77
  78     let haveColor = envAlwaysColor || (isTerminal && (nColors > 4))
  79         doColor   = not envDontColor && haveColor
  80
  81     return Policy { poColor    = doColor,
  82                     poEscape   = not envDontEscapeAnything,
  83                     poLineColor= doColor && envDoColorLines,
  84                     poIsprint  = envDontEscapeIsprint || envUseIsprint,
  85                     po8bit     = envDontEscape8bit,
  86                     poNoEscX   = envDontEscapeExtra,
  87                     poEscX     = envEscapeExtra,
  88                     poTrailing = not envDontEscapeTrailingSpace,
  89                     poCR       = envDontEscapeTrailingCR,
  90                     poAltColor = haveColor && envAlternativeColor,
  91
  92                     poSpace = False
  93                   }
  94  where
  95   getEnvBool s = safeGetEnv s >>= return.(/= "0")
  96   safeGetEnv s = getEnv s `catch` \_ -> return "0"
  97   getEnvString s = getEnv s `catch` \_ -> return ""
  98
  99
 100 -- printers
 101
 102 -- | @'fancyPrinters' h@ returns a set of printers suitable for outputting
 103 -- to @h@
 104 fancyPrinters :: Printers
 105 fancyPrinters h = Printers { colorP     = colorPrinter (getPolicy h),
 106                              invisibleP = invisiblePrinter,
 107                              hiddenP = colorPrinter (getPolicy h) Green,
 108                              userchunkP  = userchunkPrinter (getPolicy h),
 109                              defP       = escapePrinter (getPolicy h),
 110                              lineColorT = lineColorTrans (getPolicy h),
 111                              lineColorS = lineColorSuffix (getPolicy h)
 112                            }
 113
 114 -- | @'lineColorTrans' policy@ tries to color a Doc, according to policy po.
 115 -- That is, if @policy@ has @poLineColor@ set, then colors the line, otherwise
 116 -- does nothing.
 117 lineColorTrans :: Policy -> Color -> Doc -> Doc
 118 lineColorTrans po | poLineColor po = \c d -> prefix (set_color c) d <?> unsafeBothText reset_color
 119                   | otherwise      = const id
 120
 121 lineColorSuffix :: Policy -> [Printable] -> [Printable]
 122 lineColorSuffix po | poLineColor po = \d -> S reset_color : d
 123                    | otherwise      = id
 124
 125 colorPrinter :: Policy -> Color -> Printer
 126 colorPrinter po | poColor po = \c -> unDoc . color po c . Doc . escapePrinter po{poColor=False}
 127                 | otherwise  = const $ escapePrinter po
 128
 129 userchunkPrinter :: Policy -> Printer
 130 userchunkPrinter po p
 131  | not (poEscape po)   = simplePrinter p
 132  | not (poTrailing po) = escapePrinter po p
 133  | otherwise           = unDoc $ pr p
 134  where
 135   pr (S s)       = prString s
 136   pr (Both _ ps) = prPS ps
 137   pr (PS ps)     = prPS ps
 138
 139   prPS ps = let (leadPS, trailPS) = BC.spanEnd isSpace ps
 140             in if B.null trailPS
 141                 then Doc $ escapePrinter po p
 142                 else Doc (escapePrinter po (PS leadPS))
 143                   <> Doc (escapePrinter po{poSpace=True} (PS trailPS))
 144                   <> mark_escape po dollar
 145
 146   prString s = let (trail',lead') = span isSpace (reverse s)
 147                    lead = reverse lead'
 148                    trail = reverse trail'
 149                in if (not.null) trail
 150                    then Doc (escapePrinter po (S lead))
 151                      <> Doc (escapePrinter po{poSpace=True} (S trail))
 152                      <> mark_escape po dollar
 153                    else Doc (escapePrinter po p)
 154
 155 escapePrinter :: Policy -> Printer
 156 escapePrinter po
 157  | (not.poEscape) po = simplePrinter
 158  | otherwise         = unDoc . crepr
 159  where
 160   crepr p | poCR po && isEndCR p = epr (initPR p) <> cr
 161           | otherwise            = epr p
 162
 163   epr (S s)      = escape po s
 164   epr (PS ps)    = if BC.any (not.no_escape po) ps
 165                    then escape po (BC.unpack ps)
 166                    else unsafePackedString ps
 167   epr (Both s _) = escape po s
 168
 169   isEndCR (S s)        = not (null s) && last s == '\r'
 170   isEndCR (PS ps)      = not (B.null ps) && BC.last ps == '\r'
 171   isEndCR (Both _ ps)  = not (B.null ps) && BC.last ps == '\r'
 172
 173   initPR (S s)       = S $ init s
 174   initPR (PS ps)     = PS $ B.init ps
 175   initPR (Both s ps) = Both (init s) (B.init ps)
 176
 177
 178 -- escape assumes the input is in ['\0'..'\255']
 179
 180 -- | @'escape' policy string@ escapes @string@ according to the rules
 181 -- defined in 'policy', turning it into a 'Doc'.
 182 escape :: Policy -> String -> Doc
 183 escape _ "" = unsafeText ""
 184 escape po s = hcat (map escapeChar s)
 185  where
 186   escapeChar c | no_escape po c = unsafeChar c
 187   escapeChar ' ' = space
 188   escapeChar c = (emph.unsafeText.quoteChar) c
 189   emph = mark_escape po
 190
 191 -- | @'no_escape' policy c@ tells wether @c@ will be left as-is
 192 -- when escaping according to @policy@
 193 no_escape :: Policy -> Char -> Bool
 194 no_escape po c | poSpace po && isSpace c = False
 195 no_escape po c | c `elem` poEscX po = False
 196 no_escape po c | c `elem` poNoEscX po = True
 197 no_escape _ '\t' = True  -- tabs will likely be converted to spaces
 198 no_escape _ '\n' = True
 199 no_escape po c = if (poIsprint po) then isPrint c
 200                                    else isPrintableAscii c
 201                  ||  c >= '\x80' && po8bit po
 202
 203 -- | 'isPrintableAscii' tells wether a character is a printable character
 204 -- of the ascii range.
 205 isPrintableAscii :: Char -> Bool
 206 isPrintableAscii c = isAscii c && isPrint c
 207
 208
 209 -- | 'quoteChar' represents a special character as a string.
 210 --   * @quoteChar '^c'@ (where @^c@ is a control character) is @"^c"@
 211 --   * Otherwise, @quoteChar@ returns "\hex", where 'hex' is the
 212 --     hexadecimal number of the character.
 213 quoteChar :: Char -> String
 214 quoteChar c
 215  | isControl c && isPrintableAscii cHat = ['^', cHat]
 216  | otherwise = sHex
 217  where
 218   cHat = chr $ (bit 6 `xor`) $ ord c
 219   sHex = let (q, r) = quotRem (ord c) 16
 220          in ['\\', intToDigit q, intToDigit r]
 221
 222
 223 -- make colors and highlightings
 224
 225 -- | @'mark_escape' policy doc@ marks @doc@ with the appropriate
 226 -- marking for escaped characters according to @policy@
 227 mark_escape :: Policy -> Doc -> Doc
 228 mark_escape po | poAltColor po  = make_invert
 229                | poColor po     = make_color Red
 230                | otherwise      = make_asciiart
 231
 232 -- | @'color' policy color doc@ colors @doc@ with color @color@ if
 233 -- @policy@ is not set to use an alternative to color. In that case,
 234 -- it makes the text bold instead.
 235 color :: Policy -> Color -> Doc -> Doc
 236 color po | poAltColor po = \_ -> make_bold
 237          | otherwise     = make_color
 238
 239 make_color, make_color' :: Color -> Doc -> Doc
 240
 241 make_color' = with_color . set_color
 242
 243 -- memoized version of make_color'
 244 make_color Blue    = make_color' Blue
 245 make_color Red     = make_color' Red
 246 make_color Green   = make_color' Green
 247 make_color Cyan    = make_color' Cyan
 248 make_color Magenta = make_color' Magenta
 249
 250 set_color :: Color -> String
 251 set_color Blue    = "\x1B[01;34m" -- bold blue
 252 set_color Red     = "\x1B[01;31m" -- bold red
 253 set_color Green   = "\x1B[01;32m" -- bold green
 254 set_color Cyan    = "\x1B[36m"    -- light cyan
 255 set_color Magenta = "\x1B[35m"    -- light magenta
 256
 257 -- | @'make_asciiart' doc@ tries to make @doc@ (usually a
 258 -- single escaped char) stand out with the help of only plain
 259 -- ascii, i.e., no color or font style.
 260 make_asciiart :: Doc -> Doc
 261 make_asciiart x = unsafeBothText "[_" <> x <> unsafeBothText "_]"
 262
 263 -- | the string to reset the terminal's color.
 264 reset_color :: String
 265 reset_color = "\x1B[00m"
 266
 267 -- | @'with_color' color doc@ returns a colorized version of @doc@.
 268 -- @color@ is a string that represents a color, given by 'set_color'
 269 with_color :: String -> Doc -> Doc
 270 with_color c =
 271    let c' = unsafeBothText c
 272        r' = unsafeBothText reset_color
 273    in \x -> c' <> x <> r'
 274
 275
 276 -- | 'make_bold' boldens a doc.
 277 make_bold :: Doc -> Doc
 278 -- | 'make_invert' returns an invert video version of a doc.
 279 make_invert :: Doc -> Doc
 280 make_bold   = with_color "\x1B[01m"
 281 make_invert = with_color "\x1B[07m"
 282
 283 \end{code}