From 67cfcfd206b5b591d61e16fc60e225fac4fdf3e4 Mon Sep 17 00:00:00 2001 From: Vidar Holen Date: Sat, 15 Aug 2015 12:51:13 -0700 Subject: [PATCH] Separated formatters into multiple files. --- ShellCheck.cabal | 9 +- ShellCheck/Analytics.hs | 5 +- ShellCheck/Checker.hs | 10 +- ShellCheck/Formatter/CheckStyle.hs | 82 +++++++++ ShellCheck/Formatter/Format.hs | 61 +++++++ ShellCheck/Formatter/GCC.hs | 54 ++++++ ShellCheck/Formatter/JSON.hs | 58 ++++++ ShellCheck/Formatter/TTY.hs | 86 +++++++++ ShellCheck/Interface.hs | 4 + ShellCheck/Parser.hs | 6 +- shellcheck.hs | 278 ++++++----------------------- 11 files changed, 419 insertions(+), 234 deletions(-) create mode 100644 ShellCheck/Formatter/CheckStyle.hs create mode 100644 ShellCheck/Formatter/Format.hs create mode 100644 ShellCheck/Formatter/GCC.hs create mode 100644 ShellCheck/Formatter/JSON.hs create mode 100644 ShellCheck/Formatter/TTY.hs diff --git a/ShellCheck.cabal b/ShellCheck.cabal index 9990531..48b492e 100644 --- a/ShellCheck.cabal +++ b/ShellCheck.cabal @@ -46,13 +46,14 @@ library regex-tdfa, QuickCheck >= 2.7.4 exposed-modules: - ShellCheck.Checker - ShellCheck.Analyzer - ShellCheck.Parser - ShellCheck.Analytics ShellCheck.AST + ShellCheck.Analytics + ShellCheck.Analyzer + ShellCheck.Checker ShellCheck.Data + ShellCheck.Formatter.Format ShellCheck.Interface + ShellCheck.Parser ShellCheck.Regex other-modules: Paths_ShellCheck diff --git a/ShellCheck/Analytics.hs b/ShellCheck/Analytics.hs index b39b2f8..f8874f7 100644 --- a/ShellCheck/Analytics.hs +++ b/ShellCheck/Analytics.hs @@ -372,7 +372,10 @@ producesComments f s = do root <- prRoot pResult return . not . null $ runList (defaultSpec root) [f] where - pSpec = ParseSpec { psScript = s } + pSpec = ParseSpec { + psFilename = "script", + psScript = s + } pResult = runIdentity $ parseScript (mockedSystemInterface []) pSpec -- Copied from https://wiki.haskell.org/Edit_distance diff --git a/ShellCheck/Checker.hs b/ShellCheck/Checker.hs index 7700c56..91e61d8 100644 --- a/ShellCheck/Checker.hs +++ b/ShellCheck/Checker.hs @@ -47,18 +47,22 @@ checkScript :: Monad m => SystemInterface m -> CheckSpec -> m CheckResult checkScript sys spec = do results <- checkScript (csScript spec) return CheckResult { + crFilename = csFilename spec, crComments = results } where checkScript contents = do - result <- parseScript sys ParseSpec { psScript = contents } + result <- parseScript sys ParseSpec { + psFilename = csFilename spec, + psScript = contents + } let parseMessages = prComments result let analysisMessages = fromMaybe [] $ (arComments . analyzeScript . analysisSpec) <$> prRoot result let translator = tokenToPosition (prTokenPositions result) - return . sortMessages . filter shouldInclude $ + return . nub . sortMessages . filter shouldInclude $ (parseMessages ++ map translator analysisMessages) shouldInclude (PositionedComment _ (Comment _ code _)) = @@ -66,7 +70,7 @@ checkScript sys spec = do sortMessages = sortBy (comparing order) order (PositionedComment pos (Comment severity code message)) = - (posFile pos, posLine pos, posColumn pos, code, message) + (posFile pos, posLine pos, posColumn pos, severity, code, message) getPosition (PositionedComment pos _) = pos analysisSpec root = diff --git a/ShellCheck/Formatter/CheckStyle.hs b/ShellCheck/Formatter/CheckStyle.hs new file mode 100644 index 0000000..9bd7166 --- /dev/null +++ b/ShellCheck/Formatter/CheckStyle.hs @@ -0,0 +1,82 @@ +{- + Copyright 2012-2015 Vidar Holen + + 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 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 General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} +module ShellCheck.Formatter.CheckStyle (format) where + +import ShellCheck.Interface +import ShellCheck.Formatter.Format + +import Data.Char +import Data.List +import GHC.Exts +import System.IO + +format :: IO Formatter +format = return Formatter { + header = do + putStrLn "" + putStrLn "", + + onFailure = outputError, + onResult = outputResult, + + footer = putStrLn "" +} + +outputResult result contents = do + let comments = makeNonVirtual (crComments result) contents + putStrLn . formatFile (crFilename result) $ comments + +formatFile name comments = concat [ + "\n", + concatMap formatComment comments, + "" + ] + +formatComment c = concat [ + "\n" + ] + +outputError file error = putStrLn $ concat [ + "\n", + "\n", + "" + ] + + +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` " ./")] + +severity "error" = "error" +severity "warning" = "warning" +severity _ = "info" diff --git a/ShellCheck/Formatter/Format.hs b/ShellCheck/Formatter/Format.hs new file mode 100644 index 0000000..d9bfaa9 --- /dev/null +++ b/ShellCheck/Formatter/Format.hs @@ -0,0 +1,61 @@ +{- + Copyright 2012-2015 Vidar Holen + + 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 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 General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} +module ShellCheck.Formatter.Format where + +import ShellCheck.Data +import ShellCheck.Interface + +-- A formatter that carries along an arbitrary piece of data +data Formatter = Formatter { + header :: IO (), + onResult :: CheckResult -> String -> IO (), + onFailure :: FilePath -> ErrorMessage -> IO (), + footer :: IO () +} + +lineNo (PositionedComment pos _) = posLine pos +colNo (PositionedComment pos _) = posColumn pos +codeNo (PositionedComment _ (Comment _ code _)) = code +messageText (PositionedComment _ (Comment _ _ t)) = t + +severityText :: PositionedComment -> String +severityText (PositionedComment _ (Comment c _ _)) = + case c of + ErrorC -> "error" + WarningC -> "warning" + InfoC -> "info" + StyleC -> "style" + +-- Realign comments from a tabstop of 8 to 1 +makeNonVirtual comments contents = + map fix comments + where + ls = lines contents + fix c@(PositionedComment pos comment) = PositionedComment pos { + posColumn = + if lineNo c > 0 && lineNo c <= fromIntegral (length ls) + then real (ls !! fromIntegral (lineNo c - 1)) 0 0 (colNo c) + else colNo c + } comment + 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 diff --git a/ShellCheck/Formatter/GCC.hs b/ShellCheck/Formatter/GCC.hs new file mode 100644 index 0000000..ae542bf --- /dev/null +++ b/ShellCheck/Formatter/GCC.hs @@ -0,0 +1,54 @@ +{- + Copyright 2012-2015 Vidar Holen + + 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 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 General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} +module ShellCheck.Formatter.GCC (format) where + +import ShellCheck.Interface +import ShellCheck.Formatter.Format + +import Data.List +import GHC.Exts +import System.IO + +format :: IO Formatter +format = return Formatter { + header = return (), + footer = return (), + onFailure = outputError, + onResult = outputResult +} + +outputError file error = hPutStrLn stderr $ file ++ ": " ++ error + +outputResult result contents = do + let comments = makeNonVirtual (crComments result) contents + mapM_ (putStrLn . formatComment (crFilename result)) comments + +formatComment filename c = concat [ + filename, ":", + show $ lineNo c, ":", + show $ colNo c, ": ", + case severityText c of + "error" -> "error" + "warning" -> "warning" + _ -> "note", + ": ", + concat . lines $ messageText c, + " [SC", show $ codeNo c, "]" + ] diff --git a/ShellCheck/Formatter/JSON.hs b/ShellCheck/Formatter/JSON.hs new file mode 100644 index 0000000..018db27 --- /dev/null +++ b/ShellCheck/Formatter/JSON.hs @@ -0,0 +1,58 @@ +{- + Copyright 2012-2015 Vidar Holen + + 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 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 General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} +module ShellCheck.Formatter.JSON (format) where + +import ShellCheck.Interface +import ShellCheck.Formatter.Format + +import Data.IORef +import GHC.Exts +import System.IO +import Text.JSON + +format = do + ref <- newIORef [] + return Formatter { + header = return (), + onResult = collectResult ref, + onFailure = outputError, + footer = finish ref + } + +instance JSON (PositionedComment) where + showJSON comment@(PositionedComment pos (Comment level code string)) = makeObj [ + ("file", showJSON $ posFile pos), + ("line", showJSON $ posLine pos), + ("column", showJSON $ posColumn pos), + ("level", showJSON $ severityText comment), + ("code", showJSON code), + ("message", showJSON string) + ] + + readJSON = undefined + +outputError file msg = hPutStrLn stderr $ file ++ ": " ++ msg +collectResult ref result _ = + modifyIORef ref (\x -> crComments result ++ x) + +finish ref = do + list <- readIORef ref + putStrLn $ encodeStrict list + diff --git a/ShellCheck/Formatter/TTY.hs b/ShellCheck/Formatter/TTY.hs new file mode 100644 index 0000000..0b8e5dc --- /dev/null +++ b/ShellCheck/Formatter/TTY.hs @@ -0,0 +1,86 @@ +{- + Copyright 2012-2015 Vidar Holen + + 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 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 General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} +module ShellCheck.Formatter.TTY (format) where + +import ShellCheck.Interface +import ShellCheck.Formatter.Format + +import Data.List +import GHC.Exts +import System.Info +import System.IO + +format :: IO Formatter +format = return Formatter { + header = return (), + footer = return (), + onFailure = outputError, + onResult = outputResult +} + +colorForLevel level = + case level of + "error" -> 31 -- red + "warning" -> 33 -- yellow + "info" -> 32 -- green + "style" -> 32 -- green + "message" -> 1 -- bold + "source" -> 0 -- none + otherwise -> 0 -- none + +outputError file error = do + color <- getColorFunc + hPutStrLn stderr $ color "error" $ file ++ ": " ++ error + +outputResult result contents = do + color <- getColorFunc + let comments = crComments result + let fileLines = lines contents + let lineCount = fromIntegral $ length fileLines + let groups = groupWith lineNo comments + mapM_ (\x -> do + let lineNum = lineNo (head x) + let line = if lineNum < 1 || lineNum > lineCount + then "" + else fileLines !! fromIntegral (lineNum - 1) + putStrLn "" + putStrLn $ color "message" $ + "In " ++ crFilename result ++" line " ++ show lineNum ++ ":" + putStrLn (color "source" line) + mapM_ (\c -> putStrLn (color (severityText c) $ cuteIndent c)) x + putStrLn "" + ) groups + +cuteIndent :: PositionedComment -> String +cuteIndent comment = + replicate (fromIntegral $ colNo comment - 1) ' ' ++ + "^-- " ++ code (codeNo comment) ++ ": " ++ messageText comment + +code code = "SC" ++ show code + +getColorFunc = do + term <- hIsTerminalDevice stdout + let windows = "mingw" `isPrefixOf` os + return $ if term && not windows then colorComment else const id + where + colorComment level comment = + ansi (colorForLevel level) ++ comment ++ clear + clear = ansi 0 + ansi n = "\x1B[" ++ show n ++ "m" diff --git a/ShellCheck/Interface.hs b/ShellCheck/Interface.hs index 6616915..97c4d7a 100644 --- a/ShellCheck/Interface.hs +++ b/ShellCheck/Interface.hs @@ -31,16 +31,19 @@ data SystemInterface m = SystemInterface { -- ShellCheck input and output data CheckSpec = CheckSpec { + csFilename :: String, csScript :: String, csExcludedWarnings :: [Integer], csShellTypeOverride :: Maybe Shell } deriving (Show, Eq) data CheckResult = CheckResult { + crFilename :: String, crComments :: [PositionedComment] } deriving (Show, Eq) emptyCheckSpec = CheckSpec { + csFilename = "", csScript = "", csExcludedWarnings = [], csShellTypeOverride = Nothing @@ -48,6 +51,7 @@ emptyCheckSpec = CheckSpec { -- Parser input and output data ParseSpec = ParseSpec { + psFilename :: String, psScript :: String } deriving (Show, Eq) diff --git a/ShellCheck/Parser.hs b/ShellCheck/Parser.hs index 666d376..a194902 100644 --- a/ShellCheck/Parser.hs +++ b/ShellCheck/Parser.hs @@ -2223,8 +2223,8 @@ runParser sys p filename contents = sys) initialSystemState -parseShell sys contents = do - (result, state) <- runParser sys (parseWithNotes readScript) "" contents +parseShell sys name contents = do + (result, state) <- runParser sys (parseWithNotes readScript) name contents case result of Right (script, tokenMap, notes) -> return ParseResult { @@ -2267,7 +2267,7 @@ posToPos sp = Position { parseScript :: Monad m => SystemInterface m -> ParseSpec -> m ParseResult parseScript sys spec = - parseShell sys (psScript spec) + parseShell sys (psFilename spec) (psScript spec) lt x = trace (show x) x diff --git a/shellcheck.hs b/shellcheck.hs index 130d1d9..3ce3c3d 100644 --- a/shellcheck.hs +++ b/shellcheck.hs @@ -21,27 +21,26 @@ import ShellCheck.Data import ShellCheck.Checker import ShellCheck.Interface +import ShellCheck.Formatter.Format +import qualified ShellCheck.Formatter.CheckStyle +import qualified ShellCheck.Formatter.GCC +import qualified ShellCheck.Formatter.JSON +import qualified ShellCheck.Formatter.TTY + import Control.Exception import Control.Monad import Control.Monad.Except import Data.Char import Data.Functor import Data.Either -import Data.IORef -import Data.List import qualified Data.Map as Map import Data.Maybe import Data.Monoid -import GHC.Exts -import GHC.IO.Device import Prelude hiding (catch) import System.Console.GetOpt import System.Environment import System.Exit import System.IO -import System.Info -import Text.JSON -import qualified Data.Map as Map data Flag = Flag String String data Status = @@ -51,26 +50,13 @@ data Status = | SupportFailure | SyntaxFailure | RuntimeException - deriving (Ord, Eq) + deriving (Ord, Eq, Show) instance Monoid Status where mempty = NoProblems mappend = max -lineNo (PositionedComment pos _) = posLine pos -colNo (PositionedComment pos _) = posColumn pos -codeNo (PositionedComment _ (Comment _ code _)) = code -messageText (PositionedComment _ (Comment _ _ t)) = t - -severityText :: PositionedComment -> String -severityText (PositionedComment _ (Comment c _ _)) = - case c of - ErrorC -> "error" - WarningC -> "warning" - InfoC -> "info" - StyleC -> "style" - -header = "Usage: shellcheck [OPTIONS...] FILES..." +usageHeader = "Usage: shellcheck [OPTIONS...] FILES..." options = [ Option "e" ["exclude"] (ReqArg (Flag "exclude") "CODE1,CODE2..") "exclude types of warnings", @@ -82,206 +68,24 @@ options = [ (NoArg $ Flag "version" "true") "Print version information" ] -printOut = lift . hPutStrLn stdout printErr = lift . hPutStrLn stderr -instance JSON (PositionedComment) where - showJSON comment@(PositionedComment pos (Comment level code string)) = makeObj [ - ("file", showJSON $ posFile pos), - ("line", showJSON $ posLine pos), - ("column", showJSON $ posColumn pos), - ("level", showJSON $ severityText comment), - ("code", showJSON code), - ("message", showJSON string) - ] - where - - readJSON = undefined - - parseArguments :: [String] -> ExceptT Status IO ([Flag], [FilePath]) parseArguments argv = case getOpt Permute options argv of (opts, files, []) -> return (opts, files) (_, _, errors) -> do - printErr $ concat errors ++ "\n" ++ usageInfo header options + printErr $ concat errors ++ "\n" ++ usageInfo usageHeader options throwError SyntaxFailure +formats :: Map.Map String (IO Formatter) formats = Map.fromList [ -{- - ("json", forJson), - ("gcc", forGcc), - ("checkstyle", forCheckstyle), --} - ("tty", forTty) + ("checkstyle", ShellCheck.Formatter.CheckStyle.format), + ("gcc", ShellCheck.Formatter.GCC.format), + ("json", ShellCheck.Formatter.JSON.format), + ("tty", ShellCheck.Formatter.TTY.format) ] -forTty :: SystemInterface IO -> CheckSpec -> [FilePath] -> ExceptT Status IO () -forTty sys spec files = mapM_ doFile files - 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 filename = do - contents <- lift $ inputFile filename - comments <- lift (crComments <$> checkScript sys spec { csScript = contents }) - let fileLines = lines contents - let lineCount = fromIntegral $ length fileLines - let groups = groupWith lineNo comments - colorFunc <- getColorFunc - mapM_ (\x -> do - let lineNum = lineNo (head x) - let line = if lineNum < 1 || lineNum > lineCount - then "" - else fileLines !! (fromIntegral $ lineNum - 1) - printOut "" - printOut $ colorFunc "message" - ("In " ++ filename ++" line " ++ show lineNum ++ ":") - printOut (colorFunc "source" line) - mapM_ (\c -> printOut (colorFunc (severityText c) $ cuteIndent c)) x - printOut "" - ) groups - - cuteIndent :: PositionedComment -> String - cuteIndent comment = - replicate (fromIntegral $ colNo comment - 1) ' ' ++ - "^-- " ++ code (codeNo comment) ++ ": " ++ messageText comment - - code code = "SC" ++ show code - - getColorFunc = do - term <- lift $ hIsTerminalDevice stdout - let windows = "mingw" `isPrefixOf` os - return $ if term && not windows then colorComment else const id - -{- -forJson :: a -> Formatter -forJson _ result = do - let comments = concatMap getComments (crComments result) - lift $ putStrLn $ encodeStrict comments - where - getComments (_, FileResult comments) = comments - getComments (file, FileError str) = [ - PositionedComment - Position { - posFile = file, - posLine = 1, - posColumn = 1 - } - (Comment ErrorC 1000 str) - ] - --- Mimic GCC "file:line:col: (error|warning|note): message" format -forGcc :: SystemInterface IO -> Formatter -forGcc io result = do - mapM_ (uncurry process) (crComments result) - where - process filename (FileError string) = do - printErr $ string - - process filename (FileResult result) = do - fileInput <- lift $ siReadFile io filename - when (isLeft fileInput) $ do - printErr $ "Failed to re-open " ++ filename - throwError RuntimeException - let contents = fromRight fileInput - let comments = makeNonVirtual result contents - mapM_ (printOut . format filename) comments - - format filename c = concat [ - filename, ":", - show $ lineNo c, ":", - show $ colNo c, ": ", - case severityText c of - "error" -> "error" - "warning" -> "warning" - _ -> "note", - ": ", - concat . lines $ messageText c, - " [SC", show $ codeNo c, "]" - ] - --- Checkstyle compatible output. A bit of a hack to avoid XML dependencies -forCheckstyle :: SystemInterface IO -> Formatter -forCheckstyle _ result = do - printOut "" - printOut "" - statuses <- mapM process (crComments result) - printOut "" - return $ mconcat statuses - where - process (file, FileError str) = - printOut (formatError file str) - - process (file, FileResult comments) = - printOut (formatFile file 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 [ - "\n", - concatMap format comments, - "" - ] - - format c = concat [ - "\n" - ] - - formatError file msg = concat [ - "\n", - "\n", - "" - ] --} - - --- Realign comments from a tabstop of 8 to 1 -makeNonVirtual comments contents = - map fix comments - where - ls = lines contents - fix c@(PositionedComment pos comment) = PositionedComment pos { - posColumn = - if lineNo c > 0 && lineNo c <= fromIntegral (length ls) - then real (ls !! (fromIntegral $ lineNo c - 1)) 0 0 (colNo c) - else colNo c - } comment - 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 @@ -304,12 +108,7 @@ getExclusions options = in map (Prelude.read . clean) elements :: [Int] -excludeCodes codes = - filter (not . hasCode) - where - hasCode c = codeNo c `elem` codes - -toStatus = liftM (either id (const NoProblems)) . runExceptT +toStatus = liftM (either id id) . runExceptT main = do args <- getArgs @@ -327,7 +126,7 @@ statusToCode status = SupportFailure -> ExitFailure 4 RuntimeException -> ExitFailure 2 -process :: [Flag] -> [FilePath] -> ExceptT Status IO () +process :: [Flag] -> [FilePath] -> ExceptT Status IO Status process flags files = do options <- foldM (flip parseOption) emptyCheckSpec flags verifyFiles files @@ -340,9 +139,40 @@ process flags files = do mapM_ (printErr . write) $ Map.keys formats throwError SupportFailure where write s = " " ++ s - Just f -> ExceptT $ fmap Right $ return f + Just f -> ExceptT $ fmap Right f let sys = ioInterface (const False) - formatter sys options files + lift $ runFormatter sys formatter options files + +runFormatter :: SystemInterface IO -> Formatter -> CheckSpec -> [FilePath] + -> IO Status +runFormatter sys format spec files = do + header format + result <- foldM f NoProblems files + footer format + return result + where + f :: Status -> FilePath -> IO Status + f status file = do + newStatus <- process file `catch` handler file + return $ status `mappend` newStatus + handler :: FilePath -> IOException -> IO Status + handler file e = do + onFailure format file (show e) + return RuntimeException + + process :: FilePath -> IO Status + process filename = do + contents <- inputFile filename + let checkspec = spec { + csFilename = filename, + csScript = contents + } + result <- checkScript sys checkspec + onResult format result contents + return $ + if null (crComments result) + then NoProblems + else SomeProblems parseOption flag options = case flag of @@ -372,12 +202,12 @@ parseOption flag options = throwError SyntaxFailure return (Prelude.read num :: Integer) -ioInterface filter = do +ioInterface filter = SystemInterface { siReadFile = get } where - get file = do + get file = if filter file then (Right <$> inputFile file) `catch` handler else return $ Left (file ++ " was not specified as input.") @@ -390,12 +220,14 @@ inputFile file = do if file == "-" then getContents else readFile file - return contents + + seq (length contents) $ + return contents verifyFiles files = when (null files) $ do printErr "No files specified.\n" - printErr $ usageInfo header options + printErr $ usageInfo usageHeader options throwError SyntaxFailure printVersion = do