7x31
/
shellcheck
mirror of https://github.com/koalaman/shellcheck.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
shellcheck/shellcheck.hs

344 lines
11 KiB
Haskell
Raw Blame History

{-
This file is part of ShellCheck.
http://www.vidarholen.net/contents/shellcheck
ShellCheck is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
ShellCheck is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Affero General Public License for more details.
You should have received a copy of the GNU Affero General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
-}
import Control.Exception
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Error
import Data.Char
import Data.Maybe
import Data.Monoid
import GHC.Exts
import GHC.IO.Device
import Prelude hiding (catch)
import ShellCheck.Data
import ShellCheck.Options
import ShellCheck.Simple
import ShellCheck.Analytics
import System.Console.GetOpt
import System.Directory
import System.Environment
import System.Exit
import System.IO
import Text.JSON
import qualified Data.Map as Map
data Flag = Flag String String
data Status = NoProblems | SomeProblems | BadInput | SupportFailure | SyntaxFailure | RuntimeException deriving (Ord, Eq)
instance Error Status where
noMsg = RuntimeException
instance Monoid Status where
mempty = NoProblems
mappend = max
header = "Usage: shellcheck [OPTIONS...] FILES..."
options = [
Option "e" ["exclude"]
(ReqArg (Flag "exclude") "CODE1,CODE2..") "exclude types of warnings",
Option "f" ["format"]
(ReqArg (Flag "format") "FORMAT") "output format",
Option "s" ["shell"]
(ReqArg (Flag "shell") "SHELLNAME") "Specify dialect (bash,sh,ksh,zsh)",
Option "V" ["version"]
(NoArg $ Flag "version" "true") "Print version information"
]
printErr = hPutStrLn stderr
instance JSON ShellCheckComment where
showJSON c = makeObj [
("line", showJSON $ scLine c),
("column", showJSON $ scColumn c),
("level", showJSON $ scSeverity c),
("code", showJSON $ scCode c),
("message", showJSON $ scMessage c)
]
readJSON = undefined
parseArguments :: [String] -> ErrorT Status IO ([Flag], [FilePath])
parseArguments argv =
case getOpt Permute options argv of
(opts, files, []) -> return (opts, files)
(_, _, errors) -> do
liftIO . printErr $ concat errors ++ "\n" ++ usageInfo header options
throwError SyntaxFailure
formats :: Map.Map String (AnalysisOptions -> [FilePath] -> IO Status)
formats = Map.fromList [
("json", forJson),
("gcc", forGcc),
("checkstyle", forCheckstyle),
("tty", forTty)
]
toStatus = liftM (either id (const NoProblems)) . runErrorT
catchExceptions :: IO Status -> IO Status
catchExceptions action = action -- action `catch` handler
where
handler err = do
printErr $ show (err :: SomeException)
return RuntimeException
checkComments comments = if null comments then NoProblems else SomeProblems
forTty :: AnalysisOptions -> [FilePath] -> IO Status
forTty options files = do
output <- mapM doFile files
return $ mconcat output
where
clear = ansi 0
ansi n = "\x1B[" ++ show n ++ "m"
colorForLevel "error" = 31 -- red
colorForLevel "warning" = 33 -- yellow
colorForLevel "info" = 32 -- green
colorForLevel "style" = 32 -- green
colorForLevel "message" = 1 -- bold
colorForLevel "source" = 0 -- none
colorForLevel _ = 0 -- none
colorComment level comment =
ansi (colorForLevel level) ++ comment ++ clear
doFile path = catchExceptions $ do
contents <- readContents path
doInput path contents
doInput filename contents = do
let fileLines = lines contents
let lineCount = length fileLines
let comments = getComments options contents
let groups = groupWith scLine comments
colorFunc <- getColorFunc
mapM_ (\x -> do
let lineNum = scLine (head x)
let line = if lineNum < 1 || lineNum > lineCount
then ""
else fileLines !! (lineNum - 1)
putStrLn ""
putStrLn $ colorFunc "message"
("In " ++ filename ++" line " ++ show lineNum ++ ":")
putStrLn (colorFunc "source" line)
mapM_ (\c -> putStrLn (colorFunc (scSeverity c) $ cuteIndent c)) x
putStrLn ""
) groups
return . checkComments $ comments
cuteIndent comment =
replicate (scColumn comment - 1) ' ' ++
"^-- " ++ code (scCode comment) ++ ": " ++ scMessage comment
code code = "SC" ++ show code
getColorFunc = do
term <- hIsTerminalDevice stdout
return $ if term then colorComment else const id
-- This totally ignores the filenames. Fixme?
forJson :: AnalysisOptions -> [FilePath] -> IO Status
forJson options files = catchExceptions $ do
comments <- liftM concat $ mapM (commentsFor options) files
putStrLn $ encodeStrict comments
return $ checkComments comments
-- Mimic GCC "file:line:col: (error|warning|note): message" format
forGcc :: AnalysisOptions -> [FilePath] -> IO Status
forGcc options files = do
files <- mapM process files
return $ mconcat files
where
process file = catchExceptions $ do
contents <- readContents file
let comments = makeNonVirtual (getComments options contents) contents
mapM_ (putStrLn . format file) comments
return $ checkComments comments
format filename c = concat [
filename, ":",
show $ scLine c, ":",
show $ scColumn c, ": ",
case scSeverity c of
"error" -> "error"
"warning" -> "warning"
_ -> "note",
": ",
concat . lines $ scMessage c,
" [SC", show $ scCode c, "]"
]
-- Checkstyle compatible output. A bit of a hack to avoid XML dependencies
forCheckstyle :: AnalysisOptions -> [FilePath] -> IO Status
forCheckstyle options files = do
putStrLn "<?xml version='1.0' encoding='UTF-8'?>"
putStrLn "<checkstyle version='4.3'>"
statuses <- mapM process files
putStrLn "</checkstyle>"
return $ mconcat statuses
where
process file = catchExceptions $ do
comments <- commentsFor options file
putStrLn (formatFile file comments)
return $ checkComments comments
severity "error" = "error"
severity "warning" = "warning"
severity _ = "info"
attr s v = concat [ s, "='", escape v, "' " ]
escape = concatMap escape'
escape' c = if isOk c then [c] else "&#" ++ show (ord c) ++ ";"
isOk x = any ($x) [isAsciiUpper, isAsciiLower, isDigit, (`elem` " ./")]
formatFile name comments = concat [
"<file ", attr "name" name, ">\n",
concatMap format comments,
"</file>"
]
format c = concat [
"<error ",
attr "line" $ show . scLine $ c,
attr "column" $ show . scColumn $ c,
attr "severity" $ severity . scSeverity $ c,
attr "message" $ scMessage c,
attr "source" $ "ShellCheck.SC" ++ show (scCode c),
"/>\n"
]
commentsFor options file = liftM (getComments options) $ readContents file
getComments = shellCheck
readContents :: FilePath -> IO String
readContents file =
if file == "-"
then getContents
else readFile file
-- Realign comments from a tabstop of 8 to 1
makeNonVirtual comments contents =
map fix comments
where
ls = lines contents
fix c = c { scColumn = real (ls !! (scLine c - 1)) 0 0 (scColumn c) }
real _ r v target | target <= v = r
real [] r v _ = r -- should never happen
real ('\t':rest) r v target =
real rest (r+1) (v + 8 - (v `mod` 8)) target
real (_:rest) r v target = real rest (r+1) (v+1) target
getOption [] _ = Nothing
getOption (Flag var val:_) name | name == var = return val
getOption (_:rest) flag = getOption rest flag
getOptions options name =
map (\(Flag _ val) -> val) . filter (\(Flag var _) -> var == name) $ options
split char str =
split' str []
where
split' (a:rest) element =
if a == char
then reverse element : split' rest []
else split' rest (a:element)
split' [] element = [reverse element]
getExclusions options =
let elements = concatMap (split ',') $ getOptions options "exclude"
clean = dropWhile (not . isDigit)
in
map (Prelude.read . clean) elements :: [Int]
excludeCodes codes =
filter (not . hasCode)
where
hasCode c = scCode c `elem` codes
main = do
args <- getArgs
status <- toStatus $ do
(flags, files) <- parseArguments args
process flags files
exitWith $ statusToCode status
statusToCode status =
case status of
NoProblems -> ExitSuccess
SomeProblems -> ExitFailure 1
BadInput -> ExitFailure 5
SyntaxFailure -> ExitFailure 3
SupportFailure -> ExitFailure 4
RuntimeException -> ExitFailure 2
process :: [Flag] -> [FilePath] -> ErrorT Status IO ()
process flags files = do
options <- foldM (flip parseOption) defaultAnalysisOptions flags
verifyFiles files
let format = fromMaybe "tty" $ getOption flags "format"
case Map.lookup format formats of
Nothing -> do
liftIO $ do
printErr $ "Unknown format " ++ format
printErr "Supported formats:"
mapM_ (printErr . write) $ Map.keys formats
throwError SupportFailure
where write s = " " ++ s
Just f -> ErrorT $ liftM Left $ f options files
parseOption flag options =
case flag of
Flag "shell" str ->
fromMaybe (die $ "Unknown shell: " ++ str) $ do
shell <- shellForExecutable str
return $ return options { optionShellType = Just shell }
Flag "exclude" str -> do
new <- mapM parseNum $ split ',' str
let old = optionExcludes options
return options { optionExcludes = new ++ old }
Flag "version" _ -> do
liftIO printVersion
throwError NoProblems
_ -> return options
where
die s = do
liftIO $ printErr s
throwError SupportFailure
parseNum ('S':'C':str) = parseNum str
parseNum num = do
unless (all isDigit num) $ do
liftIO . printErr $ "Bad exclusion: " ++ num
throwError SyntaxFailure
return (Prelude.read num :: Integer)
verifyFiles files =
when (null files) $ do
liftIO $ printErr "No files specified.\n"
liftIO $ printErr $ usageInfo header options
throwError SyntaxFailure
printVersion = do
putStrLn "ShellCheck - shell script analysis tool"
putStrLn $ "version: " ++ shellcheckVersion
putStrLn "license: GNU Affero General Public License, version 3"
putStrLn "website: http://www.shellcheck.net"
Reference in New Issue View Git Blame Copy Permalink