{-# LANGUAGE CPP #-}
module Darcs.Util.Printer.Color
    ( unsafeRenderStringColored, traceDoc, debugDoc, fancyPrinters
    , environmentHelpColor, environmentHelpEscape, environmentHelpEscapeWhite
    , ePutDocLn
    ) where

import Darcs.Prelude

import Darcs.Util.Printer
    ( Printer, Printers, Printers'(..), Printable(..), Color(..)
    , invisiblePrinter, (<?>), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat
    , unsafeText, unsafePackedString
    , renderStringWith, prefix
    , hPutDocLnWith
    )
import Darcs.Util.Global ( whenDebugMode, putTiming )

import Debug.Trace ( trace )
import Data.Char ( isAscii, isPrint, isSpace, isControl, ord, chr )
import Data.Bits ( bit, xor )
import System.Environment ( lookupEnv )
import qualified Data.ByteString.Char8 as BC (unpack, any, last, spanEnd)
import qualified Data.ByteString       as B (null, init)
import System.IO.Unsafe ( unsafePerformIO )
import System.IO ( stderr, hIsTerminalDevice, Handle )
import Text.Printf ( printf )
#ifdef HAVE_TERMINFO
import System.Console.Terminfo( tiGetNum, setupTermFromEnv, getCapability )
import Data.Maybe ( fromMaybe )
#endif

dollar, cr :: Doc
dollar :: Doc
dollar = String -> Doc
unsafeBothText String
"$"
cr :: Doc
cr     = String -> Doc
unsafeBothText String
"\r"

-- | 'eputDocLn' puts a 'Doc', followed by a newline to stderr using
-- 'fancyPrinters'. Like putDocLn, it encodes with the user's locale.
-- This function is the recommended way to output messages that should
-- be visible to users on the console, but cannot (or should not) be
-- silenced even when --quiet is in effect.
ePutDocLn :: Doc -> IO ()
ePutDocLn :: Doc -> IO ()
ePutDocLn = Printers -> Handle -> Doc -> IO ()
hPutDocLnWith Printers
fancyPrinters Handle
stderr

debugDoc :: Doc -> IO ()
debugDoc :: Doc -> IO ()
debugDoc Doc
m = IO () -> IO ()
whenDebugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  IO ()
putTiming
  Printers -> Handle -> Doc -> IO ()
hPutDocLnWith Printers
fancyPrinters Handle
stderr Doc
m

traceDoc :: Doc -> a -> a
traceDoc :: Doc -> a -> a
traceDoc = String -> a -> a
forall a. String -> a -> a
trace (String -> a -> a) -> (Doc -> String) -> Doc -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
unsafeRenderStringColored

unsafeRenderStringColored :: Doc -> String
unsafeRenderStringColored :: Doc -> String
unsafeRenderStringColored = Printers' -> Doc -> String
renderStringWith (IO Printers' -> Printers'
forall a. IO a -> a
unsafePerformIO (Printers
fancyPrinters Handle
stderr))


-- | The 'Policy' type is a record containing the variables which control
-- how 'Doc's will be rendered on some output.
data Policy = Policy { Policy -> Bool
poColor :: Bool    -- ^ overall use of color
                     , Policy -> Bool
poEscape :: Bool   -- ^ overall use of escaping
                     , Policy -> Bool
poLineColor :: Bool -- ^ overall use of colored lines (only hunks for now)
                     , Policy -> Bool
poAltColor :: Bool -- ^ alternative to color (bold, inverse)
                     , Policy -> Bool
poIsprint :: Bool  -- ^ don't escape isprints
                     , Policy -> Bool
po8bit  :: Bool    -- ^ don't escape 8-bit chars
                     , Policy -> String
poNoEscX :: String   -- ^ extra chars to never escape
                     , Policy -> String
poEscX :: String   -- ^ extra chars to always escape
                     , Policy -> Bool
poTrailing :: Bool -- ^ escape trailing spaces
                     , Policy -> Bool
poCR :: Bool       -- ^ ignore \r at end of lines
                     , Policy -> Bool
poSpace :: Bool    -- ^ escape spaces (used with poTrailing)
                     }

-- | 'getPolicy' returns a suitable policy for a given handle.
-- The policy is chosen according to environment variables, and to the
-- type of terminal which the handle represents
getPolicy :: Handle -> IO Policy
getPolicy :: Handle -> IO Policy
getPolicy Handle
handle =
 do Bool
isTerminal <- Handle -> IO Bool
hIsTerminalDevice Handle
handle
    Int
nColors <- if Bool
isTerminal then IO Int
getTermNColors else Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0

    Bool
envDontEscapeAnything  <- String -> IO Bool
getEnvBool String
"DARCS_DONT_ESCAPE_ANYTHING"
    Bool
envDontEscapeIsprint   <- String -> IO Bool
getEnvBool String
"DARCS_DONT_ESCAPE_ISPRINT"
    Bool
envUseIsprint          <- String -> IO Bool
getEnvBool String
"DARCS_USE_ISPRINT"
    Bool
envEscape8bit      <- String -> IO Bool
getEnvBool String
"DARCS_ESCAPE_8BIT"

    String
envDontEscapeExtra  <- String -> IO String
getEnvString String
"DARCS_DONT_ESCAPE_EXTRA"
    String
envEscapeExtra      <- String -> IO String
getEnvString String
"DARCS_ESCAPE_EXTRA"

    Bool
envDontEscapeTrailingSpace  <- String -> IO Bool
getEnvBool String
"DARCS_DONT_ESCAPE_TRAILING_SPACES"
    Bool
envDontEscapeTrailingCR     <- String -> IO Bool
getEnvBool String
"DARCS_DONT_ESCAPE_TRAILING_CR"

    Bool
envDontColor         <- String -> IO Bool
getEnvBool String
"DARCS_DONT_COLOR"
    Bool
envAlwaysColor       <- String -> IO Bool
getEnvBool String
"DARCS_ALWAYS_COLOR"
    Bool
envAlternativeColor  <- String -> IO Bool
getEnvBool String
"DARCS_ALTERNATIVE_COLOR"

    let haveColor :: Bool
haveColor = Bool
envAlwaysColor Bool -> Bool -> Bool
|| (Bool
isTerminal Bool -> Bool -> Bool
&& (Int
nColors Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4))
        doColor :: Bool
doColor   = Bool -> Bool
not Bool
envDontColor Bool -> Bool -> Bool
&& Bool
haveColor

    Policy -> IO Policy
forall (m :: * -> *) a. Monad m => a -> m a
return Policy :: Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> String
-> String
-> Bool
-> Bool
-> Bool
-> Policy
Policy { poColor :: Bool
poColor    = Bool
doColor,
                    poEscape :: Bool
poEscape   = Bool -> Bool
not Bool
envDontEscapeAnything,
                    poLineColor :: Bool
poLineColor= Bool
doColor Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
envAlternativeColor,
                    poIsprint :: Bool
poIsprint  = Bool
envDontEscapeIsprint Bool -> Bool -> Bool
|| Bool
envUseIsprint,
                    po8bit :: Bool
po8bit     = Bool -> Bool
not Bool
envEscape8bit,
                    poNoEscX :: String
poNoEscX   = String
envDontEscapeExtra,
                    poEscX :: String
poEscX     = String
envEscapeExtra,
                    poTrailing :: Bool
poTrailing = Bool -> Bool
not Bool
envDontEscapeTrailingSpace,
                    poCR :: Bool
poCR       = Bool
envDontEscapeTrailingCR,
                    poAltColor :: Bool
poAltColor = Bool
haveColor Bool -> Bool -> Bool
&& Bool
envAlternativeColor,

                    poSpace :: Bool
poSpace = Bool
False
                  }
 where
  getEnvBool :: String -> IO Bool
getEnvBool String
s = Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"0") (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
s
  getEnvString :: String -> IO String
getEnvString String
s = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" String -> String
forall a. a -> a
id (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
s


{-
  - This function returns number of colors supported by current terminal
  - or -1 if color output not supported or error occured.
  - Terminal type determined by TERM env. variable.
  -}
getTermNColors :: IO Int
#ifdef HAVE_TERMINFO
getTermNColors :: IO Int
getTermNColors = do
  Terminal
t <- IO Terminal
setupTermFromEnv
  Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> (String -> Int) -> String -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (-Int
1) (Maybe Int -> Int) -> (String -> Maybe Int) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Terminal -> Capability Int -> Maybe Int
forall a. Terminal -> Capability a -> Maybe a
getCapability Terminal
t (Capability Int -> Maybe Int)
-> (String -> Capability Int) -> String -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Capability Int
tiGetNum (String -> IO Int) -> String -> IO Int
forall a b. (a -> b) -> a -> b
$ String
"colors"
#else
getTermNColors = return (-1)
#endif



-- printers

-- | @'fancyPrinters' h@ returns a set of printers suitable for outputting
-- to @h@
fancyPrinters :: Printers
fancyPrinters :: Printers
fancyPrinters Handle
h = do
  Policy
policy <- Handle -> IO Policy
getPolicy Handle
h
  Printers' -> IO Printers'
forall (m :: * -> *) a. Monad m => a -> m a
return Printers :: (Color -> Printer)
-> Printer
-> Printer
-> Printer
-> Printer
-> (Color -> Doc -> Doc)
-> ([Printable] -> [Printable])
-> Printers'
Printers {
    colorP :: Color -> Printer
colorP = Policy -> Color -> Printer
colorPrinter Policy
policy,
    invisibleP :: Printer
invisibleP = Printer
invisiblePrinter,
    hiddenP :: Printer
hiddenP = Policy -> Color -> Printer
colorPrinter Policy
policy Color
Green,
    userchunkP :: Printer
userchunkP = Policy -> Printer
userchunkPrinter Policy
policy,
    defP :: Printer
defP       = Policy -> Printer
escapePrinter Policy
policy,
    lineColorT :: Color -> Doc -> Doc
lineColorT = Policy -> Color -> Doc -> Doc
lineColorTrans Policy
policy,
    lineColorS :: [Printable] -> [Printable]
lineColorS = Policy -> [Printable] -> [Printable]
lineColorSuffix Policy
policy
  }

-- | @'lineColorTrans' policy@ tries to color a Doc, according to policy po.
-- That is, if @policy@ has @poLineColor@ set, then colors the line, otherwise
-- does nothing.
lineColorTrans :: Policy -> Color -> Doc -> Doc
lineColorTrans :: Policy -> Color -> Doc -> Doc
lineColorTrans Policy
po | Policy -> Bool
poLineColor Policy
po = \Color
c Doc
d -> String -> Doc -> Doc
prefix (Color -> String
setColor Color
c) Doc
d Doc -> Doc -> Doc
<?> String -> Doc
unsafeBothText String
resetColor
                  | Bool
otherwise      = (Doc -> Doc) -> Color -> Doc -> Doc
forall a b. a -> b -> a
const Doc -> Doc
forall a. a -> a
id

lineColorSuffix :: Policy -> [Printable] -> [Printable]
lineColorSuffix :: Policy -> [Printable] -> [Printable]
lineColorSuffix Policy
po | Policy -> Bool
poLineColor Policy
po = \[Printable]
d -> String -> Printable
S String
resetColor Printable -> [Printable] -> [Printable]
forall a. a -> [a] -> [a]
: [Printable]
d
                   | Bool
otherwise      = [Printable] -> [Printable]
forall a. a -> a
id

colorPrinter :: Policy -> Color -> Printer
colorPrinter :: Policy -> Color -> Printer
colorPrinter Policy
po | Policy -> Bool
poColor Policy
po = \Color
c -> Doc -> St -> Document
unDoc (Doc -> St -> Document) -> (Printable -> Doc) -> Printer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Policy -> Color -> Doc -> Doc
color Policy
po Color
c (Doc -> Doc) -> (Printable -> Doc) -> Printable -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> Printer -> Printable -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Policy -> Printer
escapePrinter Policy
po{poColor :: Bool
poColor=Bool
False}
                | Bool
otherwise  = Printer -> Color -> Printer
forall a b. a -> b -> a
const (Printer -> Color -> Printer) -> Printer -> Color -> Printer
forall a b. (a -> b) -> a -> b
$ Policy -> Printer
escapePrinter Policy
po

userchunkPrinter :: Policy -> Printer
userchunkPrinter :: Policy -> Printer
userchunkPrinter Policy
po Printable
p
 | Bool -> Bool
not (Policy -> Bool
poEscape Policy
po)   = Printer
simplePrinter Printable
p
 | Bool -> Bool
not (Policy -> Bool
poTrailing Policy
po) = Policy -> Printer
escapePrinter Policy
po Printable
p
 | Bool
otherwise           = Doc -> St -> Document
unDoc (Doc -> St -> Document) -> Doc -> St -> Document
forall a b. (a -> b) -> a -> b
$ Printable -> Doc
pr Printable
p
 where
  pr :: Printable -> Doc
pr (S String
s)       = String -> Doc
prString String
s
  pr (Both String
_ ByteString
ps) = ByteString -> Doc
prPS ByteString
ps
  pr (PS ByteString
ps)     = ByteString -> Doc
prPS ByteString
ps

  prPS :: ByteString -> Doc
prPS ByteString
ps = let (ByteString
leadPS, ByteString
trailPS) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BC.spanEnd Char -> Bool
isSpace ByteString
ps
            in if ByteString -> Bool
B.null ByteString
trailPS
                then (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ Policy -> Printer
escapePrinter Policy
po Printable
p
                else (St -> Document) -> Doc
Doc (Policy -> Printer
escapePrinter Policy
po (ByteString -> Printable
PS ByteString
leadPS))
                  Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> (St -> Document) -> Doc
Doc (Policy -> Printer
escapePrinter Policy
po{poSpace :: Bool
poSpace=Bool
True} (ByteString -> Printable
PS ByteString
trailPS))
                  Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Policy -> Doc -> Doc
markEscape Policy
po Doc
dollar

  prString :: String -> Doc
prString String
s = let (String
trail',String
lead') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isSpace (String -> String
forall a. [a] -> [a]
reverse String
s)
                   lead :: String
lead = String -> String
forall a. [a] -> [a]
reverse String
lead'
                   trail :: String
trail = String -> String
forall a. [a] -> [a]
reverse String
trail'
               in if (Bool -> Bool
not(Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) String
trail
                   then (St -> Document) -> Doc
Doc (Policy -> Printer
escapePrinter Policy
po (String -> Printable
S String
lead))
                     Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> (St -> Document) -> Doc
Doc (Policy -> Printer
escapePrinter Policy
po{poSpace :: Bool
poSpace=Bool
True} (String -> Printable
S String
trail))
                     Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Policy -> Doc -> Doc
markEscape Policy
po Doc
dollar
                   else (St -> Document) -> Doc
Doc (Policy -> Printer
escapePrinter Policy
po Printable
p)

escapePrinter :: Policy -> Printer
escapePrinter :: Policy -> Printer
escapePrinter Policy
po
 | (Bool -> Bool
not(Bool -> Bool) -> (Policy -> Bool) -> Policy -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Policy -> Bool
poEscape) Policy
po = Printer
simplePrinter
 | Bool
otherwise         = Doc -> St -> Document
unDoc (Doc -> St -> Document) -> (Printable -> Doc) -> Printer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Printable -> Doc
crepr
 where
  crepr :: Printable -> Doc
crepr Printable
p | Policy -> Bool
poCR Policy
po Bool -> Bool -> Bool
&& Printable -> Bool
isEndCR Printable
p = Printable -> Doc
epr (Printable -> Printable
initPR Printable
p) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
cr
          | Bool
otherwise            = Printable -> Doc
epr Printable
p

  epr :: Printable -> Doc
epr (S String
s)      = Policy -> String -> Doc
escape Policy
po String
s
  epr (PS ByteString
ps)    = if (Char -> Bool) -> ByteString -> Bool
BC.any (Bool -> Bool
not(Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Policy -> Char -> Bool
noEscape Policy
po) ByteString
ps
                   then Policy -> String -> Doc
escape Policy
po (ByteString -> String
BC.unpack ByteString
ps)
                   else ByteString -> Doc
unsafePackedString ByteString
ps
  epr (Both String
s ByteString
_) = Policy -> String -> Doc
escape Policy
po String
s

  isEndCR :: Printable -> Bool
isEndCR (S String
s)        = Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) Bool -> Bool -> Bool
&& String -> Char
forall a. [a] -> a
last String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r'
  isEndCR (PS ByteString
ps)      = Bool -> Bool
not (ByteString -> Bool
B.null ByteString
ps) Bool -> Bool -> Bool
&& ByteString -> Char
BC.last ByteString
ps Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r'
  isEndCR (Both String
_ ByteString
ps)  = Bool -> Bool
not (ByteString -> Bool
B.null ByteString
ps) Bool -> Bool -> Bool
&& ByteString -> Char
BC.last ByteString
ps Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r'

  initPR :: Printable -> Printable
initPR (S String
s)       = String -> Printable
S (String -> Printable) -> String -> Printable
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
init String
s
  initPR (PS ByteString
ps)     = ByteString -> Printable
PS (ByteString -> Printable) -> ByteString -> Printable
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B.init ByteString
ps
  initPR (Both String
s ByteString
ps) = String -> ByteString -> Printable
Both (String -> String
forall a. [a] -> [a]
init String
s) (ByteString -> ByteString
B.init ByteString
ps)


-- | @'escape' policy string@ escapes @string@ according to the rules
-- defined in 'policy', turning it into a 'Doc'.
escape :: Policy -> String -> Doc
escape :: Policy -> String -> Doc
escape Policy
_ String
"" = String -> Doc
unsafeText String
""
escape Policy
po String
s = [Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ String -> [Doc]
escape' String
s
 where
   escape' :: String -> [Doc]
escape' String
"" = []
   escape' s' :: String
s'@(Char
c:String
_) | Char -> Bool
mundane Char
c =
     let (String
printables, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
mundane String
s' in
     String -> Doc
unsafeText String
printablesDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:String -> [Doc]
escape' String
rest
   escape' (Char
c:String
rest) = (Doc -> Doc
emph (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
unsafeText (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> String
quoteChar Char
c)Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:String -> [Doc]
escape' String
rest
   mundane :: Char -> Bool
mundane Char
c = Policy -> Char -> Bool
noEscape Policy
po Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
   emph :: Doc -> Doc
emph = Policy -> Doc -> Doc
markEscape Policy
po


-- | @'noEscape' policy c@ tells wether @c@ will be left as-is
-- when escaping according to @policy@
noEscape :: Policy -> Char -> Bool
noEscape :: Policy -> Char -> Bool
noEscape Policy
po Char
c | Policy -> Bool
poSpace Policy
po Bool -> Bool -> Bool
&& Char -> Bool
isSpace Char
c = Bool
False
noEscape Policy
po Char
c | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Policy -> String
poEscX Policy
po = Bool
False
noEscape Policy
po Char
c | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Policy -> String
poNoEscX Policy
po = Bool
True
noEscape Policy
_ Char
'\t' = Bool
True  -- tabs will likely be converted to spaces
noEscape Policy
_ Char
'\n' = Bool
True
noEscape Policy
po Char
c = if Policy -> Bool
poIsprint Policy
po then Char -> Bool
isPrint Char
c
                                   else Char -> Bool
isPrintableAscii Char
c
                 Bool -> Bool -> Bool
||  Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x80' Bool -> Bool -> Bool
&& Policy -> Bool
po8bit Policy
po

-- | 'isPrintableAscii' tells wether a character is a printable character
-- of the ascii range.
isPrintableAscii :: Char -> Bool
isPrintableAscii :: Char -> Bool
isPrintableAscii Char
c = Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isPrint Char
c


-- | 'quoteChar' represents a special character as a string.
--   * @quoteChar '^c'@ (where @^c@ is a control character) is @"^c"@
--   * Otherwise, @quoteChar@ returns "\hex", where 'hex' is the
--     hexadecimal number of the character.
quoteChar :: Char -> String
quoteChar :: Char -> String
quoteChar Char
c
 | Char -> Bool
isControl Char
c Bool -> Bool -> Bool
&& Char -> Bool
isPrintableAscii Char
cHat = [Char
'^', Char
cHat]
 | Bool
otherwise = String
sHex
 where
  cHat :: Char
cHat = Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ (Int -> Int
forall a. Bits a => Int -> a
bit Int
6 Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor`) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c
  sHex :: String
sHex = String
"<U+" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Char -> String
forall r. PrintfType r => String -> r
printf String
"%04X" Char
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"


-- make colors and highlightings

-- | @'markEscape' policy doc@ marks @doc@ with the appropriate
-- marking for escaped characters according to @policy@
markEscape :: Policy -> Doc -> Doc
markEscape :: Policy -> Doc -> Doc
markEscape Policy
po  | Policy -> Bool
poAltColor Policy
po  = Doc -> Doc
makeInvert
               | Policy -> Bool
poColor Policy
po     = Color -> Doc -> Doc
makeColor Color
Red
               | Bool
otherwise      = Doc -> Doc
makeAsciiart

-- | @'color' policy color doc@ colors @doc@ with color @color@ if
-- @policy@ is not set to use an alternative to color. In that case,
-- it makes the text bold instead.
color :: Policy -> Color -> Doc -> Doc
color :: Policy -> Color -> Doc -> Doc
color Policy
po | Policy -> Bool
poAltColor Policy
po = \Color
_ -> Doc -> Doc
makeBold
         | Bool
otherwise     = Color -> Doc -> Doc
makeColor

makeColor, makeColor' :: Color -> Doc -> Doc

makeColor' :: Color -> Doc -> Doc
makeColor' = String -> Doc -> Doc
withColor (String -> Doc -> Doc) -> (Color -> String) -> Color -> Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> String
setColor

-- memoized version of makeColor'
makeColor :: Color -> Doc -> Doc
makeColor Color
Blue    = Color -> Doc -> Doc
makeColor' Color
Blue
makeColor Color
Red     = Color -> Doc -> Doc
makeColor' Color
Red
makeColor Color
Green   = Color -> Doc -> Doc
makeColor' Color
Green
makeColor Color
Cyan    = Color -> Doc -> Doc
makeColor' Color
Cyan
makeColor Color
Magenta = Color -> Doc -> Doc
makeColor' Color
Magenta

setColor :: Color -> String
setColor :: Color -> String
setColor Color
Blue    = String
"\x1B[01;34m" -- bold blue
setColor Color
Red     = String
"\x1B[01;31m" -- bold red
setColor Color
Green   = String
"\x1B[01;32m" -- bold green
setColor Color
Cyan    = String
"\x1B[36m"    -- light cyan
setColor Color
Magenta = String
"\x1B[35m"    -- light magenta

-- | @'makeAsciiart' doc@ tries to make @doc@ (usually a
-- single escaped char) stand out with the help of only plain
-- ascii, i.e., no color or font style.
makeAsciiart :: Doc -> Doc
makeAsciiart :: Doc -> Doc
makeAsciiart Doc
x = String -> Doc
unsafeBothText String
"[_" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
unsafeBothText String
"_]"

-- | the string to reset the terminal's color.
resetColor :: String
resetColor :: String
resetColor = String
"\x1B[00m"

-- | @'withColor' color doc@ returns a colorized version of @doc@.
-- @color@ is a string that represents a color, given by 'setColor'
withColor :: String -> Doc -> Doc
withColor :: String -> Doc -> Doc
withColor String
c =
   let c' :: Doc
c' = String -> Doc
unsafeBothText String
c
       r' :: Doc
r' = String -> Doc
unsafeBothText String
resetColor
   in \Doc
x -> Doc
c' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
r'


-- | 'makeBold' boldens a doc.
makeBold :: Doc -> Doc
-- | 'makeInvert' returns an invert video version of a doc.
makeInvert :: Doc -> Doc
makeBold :: Doc -> Doc
makeBold   = String -> Doc -> Doc
withColor String
"\x1B[01m"
makeInvert :: Doc -> Doc
makeInvert = String -> Doc -> Doc
withColor String
"\x1B[07m"

environmentHelpColor :: ([String], [String])
environmentHelpColor :: ([String], [String])
environmentHelpColor = ([String
"DARCS_DONT_COLOR", String
"DARCS_ALWAYS_COLOR",
                         String
"DARCS_ALTERNATIVE_COLOR"],[
  String
"If the terminal understands ANSI color escape sequences, darcs will",
  String
"highlight certain keywords and delimiters when printing patches, and",
  String
"also print hunk lines in color according to whether they are removed",
  String
"or added. This can be turned off by setting the environment variable",
  String
"DARCS_DONT_COLOR to 1.",
  String
"If you use a pager that happens to understand ANSI colors, like",
  String
"`less -R`, darcs can be forced always to highlight the output by setting",
  String
"DARCS_ALWAYS_COLOR to 1. If you can't see colors you can set",
  String
"DARCS_ALTERNATIVE_COLOR to 1, and darcs will use ANSI codes for bold",
  String
"and reverse video instead of colors."])

environmentHelpEscapeWhite :: ([String], [String])
environmentHelpEscapeWhite :: ([String], [String])
environmentHelpEscapeWhite = ([ String
"DARCS_DONT_ESCAPE_TRAILING_SPACES",
                                String
"DARCS_DONT_ESCAPE_TRAILING_CR"],[
  String
"By default darcs will escape (by highlighting if possible) any kind",
  String
"of spaces at the end of lines when showing patch contents.",
  String
"If you don't want this you can turn it off by setting",
  String
"DARCS_DONT_ESCAPE_TRAILING_SPACES to 1. A special case exists",
  String
"for only carriage returns: DARCS_DONT_ESCAPE_TRAILING_CR"])

environmentHelpEscape :: ([String], [String])
environmentHelpEscape :: ([String], [String])
environmentHelpEscape = ([String
"DARCS_DONT_ESCAPE_ANYTHING",
                          String
"DARCS_DONT_ESCAPE_EXTRA",
                          String
"DARCS_ESCAPE_EXTRA",
                          String
"DARCS_DONT_ESCAPE_ISPRINT",
                          String
"DARCS_ESCAPE_8BIT"],[
  String
"Darcs needs to escape certain characters when printing patch contents to",
  String
"a terminal, depending on the encoding specified in your locale setting.",
  String
"",
  String
"By default, darcs assumes that your locale encoding is ASCII compatible.",
  String
"This includes UTF-8 and some 8-bit encodings like ISO/IEC-8859 (including",
  String
"its variants). Since ASCII contains control characters like backspace",
  String
"(which could hide patch content from the user when printed literally to",
  String
"the terminal), and even ones that may introduce security risks such as",
  String
"redirecting commands to the shell, darcs needs to escape such characters.",
  String
"They are printed as `^<control letter>` or `\\<hex code>`. Darcs also uses",
  String
"special markup for line endings that are preceeded by white space, since",
  String
"the white space would otherwise not be recognizable.",
  String
"",
  String
"If you use an encoding that is not ASCII compatible, things are somewhat",
  String
"less smooth. Such encodings include UTF-16 and UTF-32, as well as many of",
  String
"the encodings that became obsolete with unicode. In this case you have two",
  String
"options: you can set DARCS_DONT_ESCAPE_ANYTHING to 1. Then everything that",
  String
"doesn't flip code sets should work, and so will all the bells and whistles",
  String
"in your terminal. This environment variable can also be handy if you pipe",
  String
"the output to a pager or external filter that knows better than darcs how to",
  String
"handle your encoding. Note that all escaping, including the special escaping",
  String
"of any line ending spaces, will be turned off by this setting.",
  String
"",
  String
"Another possibility is to explicitly tell darcs to not escape or escape",
  String
"certain bytes, using DARCS_DONT_ESCAPE_EXTRA and DARCS_ESCAPE_EXTRA. Their",
  String
"values should be strings consisting of the verbatim bytes in question. The",
  String
"do-escapes take precedence over the dont-escapes. Space characters are still",
  String
"escaped at line endings though. The special environment variable",
  String
"DARCS_DONT_ESCAPE_TRAILING_CR turns off escaping of carriage return last on",
  String
"the line (DOS style).",
  String
"",
  String
"For historical reasons, darcs also supports DARCS_DONT_ESCAPE_ISPRINT and",
  String
"DARCS_USE_ISPRINT (which are synonyms). These make sense only for 8-bit",
  String
"encodings like ISO-8859 and are no longer needed since nowadays darcs does",
  String
"the right thing here by default.",
  String
"",
  String
"Finally, if you are in a highly security sensitive situation (or just",
  String
"paranoid for other reasons), you can set DARCS_ESCAPE_8BIT to 1. This will",
  String
"cause darcs to escape every non-ASCII byte in addition to ASCII control",
  String
"characters."])