diff --git a/ShellCheck.cabal b/ShellCheck.cabal
index 1cf57ba..12ed9f0 100644
--- a/ShellCheck.cabal
+++ b/ShellCheck.cabal
@@ -62,6 +62,7 @@ executable shellcheck
mtl,
parsec,
regex-compat,
+ transformers,
QuickCheck >= 2.2
main-is: shellcheck.hs
@@ -76,6 +77,7 @@ test-suite test-shellcheck
mtl,
parsec,
regex-compat,
+ transformers,
QuickCheck >= 2.2
main-is: test/shellcheck.hs
diff --git a/ShellCheck/Parser.hs b/ShellCheck/Parser.hs
index 2b9ba25..25abbf7 100644
--- a/ShellCheck/Parser.hs
+++ b/ShellCheck/Parser.hs
@@ -16,7 +16,7 @@
along with this program. If not, see <http://www.gnu.org/licenses/>.
-}
{-# LANGUAGE NoMonomorphismRestriction, TemplateHaskell #-}
-module ShellCheck.Parser (Note(..), Severity(..), parseShell, ParseResult(..), ParseNote(..), sortNotes, noteToParseNote, runTests) where
+module ShellCheck.Parser (Note(..), Severity(..), parseShell, ParseResult(..), ParseNote(..), sortNotes, noteToParseNote, runTests, readScript) where
import ShellCheck.AST
import ShellCheck.Data
diff --git a/shellcheck.hs b/shellcheck.hs
index 7d38707..d4f6d84 100644
--- a/shellcheck.hs
+++ b/shellcheck.hs
@@ -17,8 +17,11 @@
-}
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)
@@ -34,23 +37,29 @@ 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 ['f'] ["format"]
+ Option "f" ["format"]
(ReqArg (Flag "format") "FORMAT") "output format",
- Option ['e'] ["exclude"]
+ Option "e" ["exclude"]
(ReqArg (Flag "exclude") "CODE1,CODE2..") "exclude types of warnings",
- Option ['s'] ["shell"]
+ Option "s" ["shell"]
(ReqArg (Flag "shell") "SHELLNAME") "Specify dialect (bash,sh,ksh,zsh)",
- Option ['V'] ["version"]
+ Option "V" ["version"]
(NoArg $ Flag "version" "true") "Print version information"
]
printErr = hPutStrLn stderr
-syntaxFailure = ExitFailure 3
-supportFailure = ExitFailure 4
instance JSON ShellCheckComment where
showJSON c = makeObj [
@@ -62,16 +71,18 @@ instance JSON ShellCheckComment where
]
readJSON = undefined
+parseArguments :: [String] -> ErrorT Status IO ([Flag], [FilePath])
parseArguments argv =
case getOpt Permute options argv of
(opts, files, []) -> do
verifyOptions opts files
- return $ Just (opts, files)
+ return (opts, files)
(_, _, errors) -> do
- printErr $ concat errors ++ "\n" ++ usageInfo header options
- exitWith syntaxFailure
+ liftIO . printErr $ concat errors ++ "\n" ++ usageInfo header options
+ throwError SyntaxFailure
+formats :: Map.Map String ([Flag] -> [FilePath] -> IO Status)
formats = Map.fromList [
("json", forJson),
("gcc", forGcc),
@@ -79,9 +90,21 @@ formats = Map.fromList [
("tty", forTty)
]
+toStatus = liftM (either id (const NoProblems)) . runErrorT
+
+catchExceptions :: IO Status -> IO Status
+catchExceptions action = action `catch` handler
+ where
+ handler err = do
+ printErr $ show (err :: SomeException)
+ return RuntimeException
+
+checkComments comments = if null comments then NoProblems else SomeProblems
+
+forTty :: [Flag] -> [FilePath] -> IO Status
forTty options files = do
output <- mapM doFile files
- return $ and output
+ return $ mconcat output
where
clear = ansi 0
ansi n = "\x1B[" ++ show n ++ "m"
@@ -97,7 +120,7 @@ forTty options files = do
colorComment level comment =
ansi (colorForLevel level) ++ comment ++ clear
- doFile path = do
+ doFile path = catchExceptions $ do
contents <- readContents path
doInput path contents
@@ -119,34 +142,36 @@ forTty options files = do
mapM_ (\c -> putStrLn (colorFunc (scSeverity c) $ cuteIndent c)) x
putStrLn ""
) groups
- return $ null comments
+ return . checkComments $ comments
cuteIndent comment =
replicate (scColumn comment - 1) ' ' ++
"^-- " ++ code (scCode comment) ++ ": " ++ scMessage comment
- code code = "SC" ++ (show code)
+ 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 options files = do
+forJson :: [Flag] -> [FilePath] -> IO Status
+forJson options files = catchExceptions $ do
comments <- liftM concat $ mapM (commentsFor options) files
putStrLn $ encodeStrict comments
- return . null $ comments
+ return $ checkComments comments
-- Mimic GCC "file:line:col: (error|warning|note): message" format
+forGcc :: [Flag] -> [FilePath] -> IO Status
forGcc options files = do
files <- mapM process files
- return $ and files
+ return $ mconcat files
where
- process file = do
+ process file = catchExceptions $ do
contents <- readContents file
let comments = makeNonVirtual (getComments options contents) contents
mapM_ (putStrLn . format file) comments
- return $ null comments
+ return $ checkComments comments
format filename c = concat [
filename, ":",
@@ -162,20 +187,18 @@ forGcc options files = do
]
-- Checkstyle compatible output. A bit of a hack to avoid XML dependencies
+forCheckstyle :: [Flag] -> [FilePath] -> IO Status
forCheckstyle options files = do
putStrLn "<?xml version='1.0' encoding='UTF-8'?>"
putStrLn "<checkstyle version='4.3'>"
- statuses <- mapM (\x -> process x `catch` report) files
+ statuses <- mapM process files
putStrLn "</checkstyle>"
- return $ and statuses
+ return $ mconcat statuses
where
- process file = do
+ process file = catchExceptions $ do
comments <- commentsFor options file
putStrLn (formatFile file comments)
- return $ null comments
- report error = do
- printErr $ show (error :: SomeException)
- return False
+ return $ checkComments comments
severity "error" = "error"
severity "warning" = "warning"
@@ -197,12 +220,11 @@ forCheckstyle options files = do
attr "column" $ show . scColumn $ c,
attr "severity" $ severity . scSeverity $ c,
attr "message" $ scMessage c,
- attr "source" $ "ShellCheck.SC" ++ (show $ scCode c),
+ attr "source" $ "ShellCheck.SC" ++ show (scCode c),
"/>\n"
]
-commentsFor options file =
- liftM (getComments options) $ readContents file
+commentsFor options file = liftM (getComments options) $ readContents file
getComments options contents =
excludeCodes (getExclusions options) $ shellCheck contents analysisOptions
@@ -214,7 +236,13 @@ getComments options contents =
return $ ForceShell sh
-readContents file = if file == "-" then getContents else readFile file
+readContents :: FilePath -> IO String
+readContents file =
+ if file == "-"
+ then getContents
+ else readFile file
+ where
+ force s = foldr (flip const) s s
-- Realign comments from a tabstop of 8 to 1
makeNonVirtual comments contents =
@@ -240,7 +268,7 @@ split char str =
where
split' (a:rest) element =
if a == char
- then (reverse element) : split' rest []
+ then reverse element : split' rest []
else split' rest (a:element)
split' [] element = [reverse element]
@@ -257,45 +285,51 @@ excludeCodes codes =
main = do
args <- getArgs
- parsedArgs <- parseArguments args
- code <- do
- status <- process parsedArgs
- return $ if status then ExitSuccess else ExitFailure 1
- `catch` return
- `catch` \err -> do
- printErr $ show (err :: SomeException)
- return $ ExitFailure 2
- exitWith code
+ status <- toStatus $ do
+ (flags, files) <- parseArguments args
+ process flags files
+ exitWith $ statusToCode status
-process Nothing = return False
-process (Just (options, files)) =
+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 options files =
let format = fromMaybe "tty" $ getOption options "format" in
case Map.lookup format formats of
Nothing -> do
- printErr $ "Unknown format " ++ format
- printErr $ "Supported formats:"
- mapM_ (printErr . write) $ Map.keys formats
- exitWith supportFailure
+ liftIO $ do
+ printErr $ "Unknown format " ++ format
+ printErr "Supported formats:"
+ mapM_ (printErr . write) $ Map.keys formats
+ throwError SupportFailure
where write s = " " ++ s
- Just f -> do
- f options files
+ Just f -> ErrorT $ liftM Left $ f options files
+verifyOptions :: [Flag] -> [FilePath] -> ErrorT Status IO ()
verifyOptions opts files = do
- when (isJust $ getOption opts "version") printVersionAndExit
+ when (isJust $ getOption opts "version") $ do
+ liftIO printVersion
+ throwError NoProblems
let shell = getOption opts "shell" in
when (isJust shell && isNothing (shell >>= shellForExecutable)) $ do
- printErr $ "Unknown shell: " ++ (fromJust shell)
- exitWith supportFailure
+ liftIO $ printErr ("Unknown shell: " ++ fromJust shell)
+ throwError SupportFailure
when (null files) $ do
- printErr "No files specified.\n"
- printErr $ usageInfo header options
- exitWith syntaxFailure
+ liftIO $ printErr "No files specified.\n"
+ liftIO $ printErr $ usageInfo header options
+ throwError SyntaxFailure
-printVersionAndExit = do
- putStrLn $ "ShellCheck - shell script analysis tool"
+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"
- exitWith ExitSuccess
+ putStrLn "license: GNU Affero General Public License, version 3"
+ putStrLn "website: http://www.shellcheck.net"