1 {-# OPTIONS -fno-warn-orphans #-}
    2 module Darcs.ColorPrinter ( errorDoc, traceDoc, assertDoc, fancyPrinters ) where
    3 
    4 import Debug.Trace ( trace )
    5 import System.IO ( stderr )
    6 import Darcs.External (getTermNColors)
    7 import Printer (Printer, Printers, Printers'(..), Printable(..), Color(..),
    8                 invisiblePrinter, (<>), (<?>), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat,
    9                 unsafeText, unsafeChar, space, unsafePackedString,
   10                 renderStringWith, prefix )
   11 import Data.Char ( isAscii, isPrint, isSpace, isControl, ord, chr, intToDigit )
   12 import Data.Bits ( bit, xor )
   13 import System.Environment ( getEnv )
   14 import qualified Data.ByteString.Char8 as BC (unpack, any, last, spanEnd)
   15 import qualified Data.ByteString       as B (null, init)
   16 import System.IO.Unsafe ( unsafePerformIO )
   17 import System.IO ( hIsTerminalDevice, Handle )
   18 
   19 dollar, cr :: Doc
   20 dollar = unsafeBothText "$"
   21 cr     = unsafeBothText "\r"
   22 
   23 errorDoc :: Doc -> a
   24 errorDoc = error . show
   25 
   26 traceDoc :: Doc -> a -> a
   27 traceDoc d = trace (show d)
   28 
   29 assertDoc :: Maybe Doc -> a -> a
   30 assertDoc Nothing x = x
   31 assertDoc (Just e) _ = errorDoc e
   32 
   33 instance Show Doc where
   34     show = renderStringWith (fancyPrinters stderr)
   35 
   36 -- policy
   37 -- | the 'Policy' type is a record containing the variables which control
   38 -- how 'Doc's will be rendered on some output.
   39 data Policy = Policy { poColor :: Bool    -- ^ overall use of color
   40                      , poEscape :: Bool   -- ^ overall use of escaping
   41                      , poLineColor :: Bool -- ^ overall use of colored lines (only hunks for now)
   42                      , poAltColor :: Bool -- ^ alternative to color (bold, inverse)
   43                      , poIsprint :: Bool  -- ^ don't escape isprints
   44                      , po8bit  :: Bool    -- ^ don't escape 8-bit chars
   45                      , poNoEscX :: String   -- ^ extra chars to never escape
   46                      , poEscX :: String   -- ^ extra chars to always escape
   47                      , poTrailing :: Bool -- ^ escape trailing spaces
   48                      , poCR :: Bool       -- ^ ignore \r at end of lines
   49                      , poSpace :: Bool    -- ^ escape spaces (used with poTrailing)
   50                      }
   51 
   52 {-# NOINLINE getPolicy #-}
   53 -- | 'getPolicy' returns a suitable policy for a given handle.
   54 -- The policy is chosen according to environment variables, and to the
   55 -- type of terminal which the handle represents
   56 getPolicy :: Handle -> Policy
   57 getPolicy handle = unsafePerformIO $
   58  do isTerminal <- hIsTerminalDevice handle
   59     nColors <- if isTerminal then getTermNColors else return 0
   60 
   61     envDontEscapeAnything  <- getEnvBool "DARCS_DONT_ESCAPE_ANYTHING"
   62     envDontEscapeIsprint   <- getEnvBool "DARCS_DONT_ESCAPE_ISPRINT"
   63     envUseIsprint          <- getEnvBool "DARCS_USE_ISPRINT" -- for backwards-compatibility
   64     envDontEscape8bit      <- getEnvBool "DARCS_DONT_ESCAPE_8BIT"
   65 
   66     envDontEscapeExtra  <- getEnvString "DARCS_DONT_ESCAPE_EXTRA"
   67     envEscapeExtra      <- getEnvString "DARCS_ESCAPE_EXTRA"
   68 
   69     envDontEscapeTrailingSpace  <- getEnvBool "DARCS_DONT_ESCAPE_TRAILING_SPACES"
   70     envDontEscapeTrailingCR     <- getEnvBool "DARCS_DONT_ESCAPE_TRAILING_CR"
   71 
   72     envDontColor         <- getEnvBool "DARCS_DONT_COLOR"
   73     envAlwaysColor       <- getEnvBool "DARCS_ALWAYS_COLOR"
   74     envAlternativeColor  <- getEnvBool "DARCS_ALTERNATIVE_COLOR"
   75     envDoColorLines    <- getEnvBool "DARCS_DO_COLOR_LINES"
   76 
   77     let haveColor = envAlwaysColor || (isTerminal && (nColors > 4))
   78         doColor   = not envDontColor && haveColor
   79 
   80     return Policy { poColor    = doColor,
   81                     poEscape   = not envDontEscapeAnything,
   82                     poLineColor= doColor && envDoColorLines,
   83                     poIsprint  = envDontEscapeIsprint || envUseIsprint,
   84                     po8bit     = envDontEscape8bit,
   85                     poNoEscX   = envDontEscapeExtra,
   86                     poEscX     = envEscapeExtra,
   87                     poTrailing = not envDontEscapeTrailingSpace,
   88                     poCR       = envDontEscapeTrailingCR,
   89                     poAltColor = haveColor && envAlternativeColor,
   90 
   91                     poSpace = False
   92                   }
   93  where
   94   getEnvBool s = safeGetEnv s >>= return.(/= "0")
   95   safeGetEnv s = getEnv s `catch` \_ -> return "0"
   96   getEnvString s = getEnv s `catch` \_ -> return ""
   97 
   98 
   99 -- printers
  100 
  101 -- | @'fancyPrinters' h@ returns a set of printers suitable for outputting
  102 -- to @h@
  103 fancyPrinters :: Printers
  104 fancyPrinters h = let policy = getPolicy h in 
  105                       Printers { colorP = colorPrinter policy,
  106                              invisibleP = invisiblePrinter,
  107                              hiddenP = colorPrinter policy Green,
  108                              userchunkP = userchunkPrinter policy,
  109                              defP       = escapePrinter policy,
  110                              lineColorT = lineColorTrans policy,
  111                              lineColorS = lineColorSuffix policy
  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"