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