Add initial support for --color

This commit is contained in:
David Haguenauer 2015-12-03 11:15:32 -05:00
parent bd359c5c0f
commit a3d4101d6c
4 changed files with 40 additions and 8 deletions

View File

@ -48,6 +48,7 @@ checkScript sys spec = do
results <- checkScript (csScript spec) results <- checkScript (csScript spec)
return CheckResult { return CheckResult {
crFilename = csFilename spec, crFilename = csFilename spec,
crColorOption = csColorOption spec,
crComments = results crComments = results
} }
where where

View File

@ -46,11 +46,11 @@ colorForLevel level =
otherwise -> 0 -- none otherwise -> 0 -- none
outputError file error = do outputError file error = do
color <- getColorFunc color <- getColorFunc $ ColorAuto -- FIXME: should respect --color
hPutStrLn stderr $ color "error" $ file ++ ": " ++ error hPutStrLn stderr $ color "error ZZZ" $ file ++ ": " ++ error
outputResult result contents = do outputResult result contents = do
color <- getColorFunc color <- getColorFunc $ crColorOption result
let comments = crComments result let comments = crComments result
let fileLines = lines contents let fileLines = lines contents
let lineCount = fromIntegral $ length fileLines let lineCount = fromIntegral $ length fileLines
@ -75,10 +75,15 @@ cuteIndent comment =
code code = "SC" ++ show code code code = "SC" ++ show code
getColorFunc = do getColorFunc colorOption = do
term <- hIsTerminalDevice stdout term <- hIsTerminalDevice stdout
let windows = "mingw" `isPrefixOf` os let windows = "mingw" `isPrefixOf` os
return $ if term && not windows then colorComment else const id let isUsableTty = term && not windows
let useColor = case colorOption of
ColorAlways -> True
ColorNever -> False
ColorAuto -> isUsableTty
return $ if useColor then colorComment else const id
where where
colorComment level comment = colorComment level comment =
ansi (colorForLevel level) ++ comment ++ clear ansi (colorForLevel level) ++ comment ++ clear

View File

@ -34,21 +34,30 @@ data CheckSpec = CheckSpec {
csFilename :: String, csFilename :: String,
csScript :: String, csScript :: String,
csExcludedWarnings :: [Integer], csExcludedWarnings :: [Integer],
csColorOption :: ColorOptions,
csShellTypeOverride :: Maybe Shell csShellTypeOverride :: Maybe Shell
} deriving (Show, Eq) } deriving (Show, Eq)
data CheckResult = CheckResult { data CheckResult = CheckResult {
crFilename :: String, crFilename :: String,
crComments :: [PositionedComment] crComments :: [PositionedComment],
crColorOption :: ColorOptions
} deriving (Show, Eq) } deriving (Show, Eq)
emptyCheckSpec = CheckSpec { emptyCheckSpec = CheckSpec {
csFilename = "", csFilename = "",
csScript = "", csScript = "",
csExcludedWarnings = [], csExcludedWarnings = [],
csShellTypeOverride = Nothing csShellTypeOverride = Nothing,
csColorOption = ColorAuto
} }
data ColorOptions =
ColorAuto
| ColorAlways
| ColorNever
deriving (Ord, Eq, Show)
-- Parser input and output -- Parser input and output
data ParseSpec = ParseSpec { data ParseSpec = ParseSpec {
psFilename :: String, psFilename :: String,

View File

@ -59,7 +59,8 @@ instance Monoid Status where
data Options = Options { data Options = Options {
checkSpec :: CheckSpec, checkSpec :: CheckSpec,
externalSources :: Bool externalSources :: Bool,
color :: ColorOptions
} }
defaultOptions = Options { defaultOptions = Options {
@ -73,6 +74,8 @@ options = [
(ReqArg (Flag "exclude") "CODE1,CODE2..") "exclude types of warnings", (ReqArg (Flag "exclude") "CODE1,CODE2..") "exclude types of warnings",
Option "f" ["format"] Option "f" ["format"]
(ReqArg (Flag "format") "FORMAT") "output format", (ReqArg (Flag "format") "FORMAT") "output format",
Option "C" ["color"]
(ReqArg (Flag "color") "WHEN") "Set use of color (auto, always, never)",
Option "s" ["shell"] Option "s" ["shell"]
(ReqArg (Flag "shell") "SHELLNAME") "Specify dialect (sh,bash,dash,ksh)", (ReqArg (Flag "shell") "SHELLNAME") "Specify dialect (sh,bash,dash,ksh)",
Option "x" ["external-sources"] Option "x" ["external-sources"]
@ -195,6 +198,13 @@ runFormatter sys format options files = do
then NoProblems then NoProblems
else SomeProblems else SomeProblems
parseColorOption colorOption =
case colorOption of
"auto" -> ColorAuto
"always" -> ColorAlways
"never" -> ColorNever
_ -> error $ "Bad value for --color `" ++ colorOption ++ "'"
parseOption flag options = parseOption flag options =
case flag of case flag of
Flag "shell" str -> Flag "shell" str ->
@ -224,6 +234,13 @@ parseOption flag options =
externalSources = True externalSources = True
} }
Flag "color" color ->
return options {
checkSpec = (checkSpec options) {
csColorOption = parseColorOption color
}
}
_ -> return options _ -> return options
where where
die s = do die s = do