Initial version
This commit is contained in:
Alexander Kobjolke
commit
04b878f078
28 changed files with 1771 additions and 0 deletions
357
src/Annotator.hs
Normal file
357
src/Annotator.hs
Normal file
|
|
@ -0,0 +1,357 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
|
||||
module Annotator (defaultMain) where
|
||||
|
||||
import System.Environment (getArgs)
|
||||
import System.IO
|
||||
import System.Exit
|
||||
import System.Console.GetOpt
|
||||
import System.Directory (doesFileExist)
|
||||
import System.Posix.Files
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Function (on)
|
||||
import Data.List (delete, intercalate, foldl', nub)
|
||||
import Data.Foldable (foldlM)
|
||||
import Data.Char (isSpace)
|
||||
import Data.Ord
|
||||
import Data.Monoid
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Version as Vsn
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
|
||||
import Annotator.Rule
|
||||
import Annotator.Annotation
|
||||
|
||||
version :: Vsn.Version
|
||||
version = Vsn.makeVersion [0,0,2,0]
|
||||
|
||||
type App a = ReaderT Options IO a
|
||||
|
||||
data Verbosity = Silent | Low | Chatty
|
||||
deriving (Show, Enum, Eq, Ord, Bounded)
|
||||
|
||||
data ShowVersion = FullVersion | ShortVersion
|
||||
deriving (Show, Eq)
|
||||
|
||||
increaseVerbosity :: Verbosity -> Verbosity
|
||||
increaseVerbosity v
|
||||
| v == maxBound = v
|
||||
| otherwise = succ v
|
||||
|
||||
data Options = Options
|
||||
{ inplace :: Bool
|
||||
, verbosity :: Verbosity
|
||||
, showVersion :: Maybe ShowVersion
|
||||
, showHelp :: Bool
|
||||
, contextLines :: Int
|
||||
, onlyNewest :: Bool
|
||||
, annotationFiles :: [FilePath]
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
defaultOptions :: Options
|
||||
defaultOptions = Options
|
||||
{ inplace = False
|
||||
, verbosity = Silent
|
||||
, showVersion = Nothing
|
||||
, showHelp = False
|
||||
, contextLines = 0
|
||||
, onlyNewest = True
|
||||
, annotationFiles = []
|
||||
}
|
||||
|
||||
options :: [OptDescr (Options -> Options)]
|
||||
options =
|
||||
[ Option ['v'] ["verbose"]
|
||||
(NoArg (\opts -> opts { verbosity = increaseVerbosity (verbosity opts)}))
|
||||
"be more verbose, pass multiple times to increase verbosity"
|
||||
, Option ['i'] ["inplace"]
|
||||
(NoArg (\opts -> opts { inplace = True}))
|
||||
"replace source-file after inserting annotations"
|
||||
, Option ['V'] ["version"]
|
||||
(NoArg (\opts -> opts { showVersion = Just FullVersion }))
|
||||
"show version"
|
||||
, Option [] ["short-version"]
|
||||
(NoArg (\opts -> opts { showVersion = Just ShortVersion }))
|
||||
"show version"
|
||||
, Option ['h'] ["help"]
|
||||
(NoArg (\opts -> opts { showHelp = True }))
|
||||
"show usage information"
|
||||
, Option ['a'] ["all"]
|
||||
(NoArg (\opts -> opts { onlyNewest = False}))
|
||||
"handle all defects not just Newest"
|
||||
, Option ['C'] ["context"]
|
||||
(OptArg ((\f opts -> opts { contextLines = fromMaybe 0 $ readMaybe f }) . fromMaybe "0") "NUM")
|
||||
"specify how much context should be shown around a violation"
|
||||
, Option ['A'] ["annotations"]
|
||||
(ReqArg (\f opts -> opts { annotationFiles = (nub $ annotationFiles opts ++ [f]) }) "FILE")
|
||||
"load automatic annotation rules"
|
||||
]
|
||||
|
||||
readMaybe :: (Read a) => String -> Maybe a
|
||||
readMaybe s = case reads s of
|
||||
[(n,[])] -> Just n
|
||||
_ -> Nothing
|
||||
|
||||
parseOptions :: [String] -> IO (Options, [String])
|
||||
parseOptions argv =
|
||||
case getOpt Permute options argv of
|
||||
(o, n, []) -> pure (foldl' (flip id) defaultOptions o, n)
|
||||
(_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options))
|
||||
where
|
||||
header = "Usage: annotator [OPTIONS] files..."
|
||||
|
||||
verbose :: Verbosity -> String -> App ()
|
||||
verbose v s = do
|
||||
opts <- ask
|
||||
liftIO $ when (verbosity opts >= v) $ hPutStrLn stderr s
|
||||
|
||||
defaultMain :: IO ()
|
||||
defaultMain = do
|
||||
(opts, defects) <- getArgs >>= parseOptions
|
||||
let fn = case defects of
|
||||
[f] -> f
|
||||
_ -> "defects.err"
|
||||
|
||||
case showVersion opts of
|
||||
Just FullVersion -> do
|
||||
putStrLn $ unlines
|
||||
[
|
||||
"Annotator v" <> (Vsn.showVersion version)
|
||||
, "Copyright (c) 2022 Alexander Kobjolke <alexander.kobjolke@atlas-elektronik.com>"
|
||||
]
|
||||
exitWith ExitSuccess
|
||||
Just ShortVersion -> do
|
||||
putStrLn $ Vsn.showVersion version
|
||||
exitWith ExitSuccess
|
||||
Nothing -> pure ()
|
||||
|
||||
when (showHelp opts) $ do
|
||||
putStrLn $ usageInfo header options
|
||||
exitWith ExitSuccess
|
||||
|
||||
runReaderT (genericMain fn) opts
|
||||
|
||||
where
|
||||
header = unlines $
|
||||
[
|
||||
"Usage: annotator [OPTIONS] files..."
|
||||
, ""
|
||||
, "A tool to semi-automatically add Coverity source-code annotations based on found defects."
|
||||
, ""
|
||||
]
|
||||
|
||||
data Age = Old | New | Newest
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Violation = Violation {
|
||||
filename :: !FilePath,
|
||||
line :: !Int,
|
||||
age :: !Age,
|
||||
rule :: !Rule,
|
||||
description :: !String
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
split :: Int -> (a -> Bool) -> [a] -> [[a]]
|
||||
split _ _ [] = []
|
||||
split n p xs
|
||||
| n > 0 = case break p xs of
|
||||
(match, []) -> [match]
|
||||
(match, (_ : rest)) -> match : split (n-1) p rest
|
||||
| otherwise = [xs]
|
||||
|
||||
parseViolations :: String -> [Violation]
|
||||
parseViolations = map parseViolation . lines
|
||||
|
||||
removeSuffix :: String -> String -> String
|
||||
removeSuffix suffix text = stripped
|
||||
where
|
||||
(p, s) = splitAt (length text - length suffix) text
|
||||
stripped = if s == suffix then p else text
|
||||
|
||||
parseViolation :: String -> Violation
|
||||
parseViolation s = case split 4 (== ':') s of
|
||||
(file:line:_error:rule':desc) -> violation
|
||||
where
|
||||
violation = Violation file (read line) a (Rule (removeSuffix "_violation" r)) (dropWhile isSpace $ concat desc)
|
||||
(_:age':r:_) = split 2 (== ' ') rule'
|
||||
a = case (delete ',' age') of
|
||||
"Newest" -> Newest
|
||||
"New" -> New
|
||||
_ -> Old
|
||||
_ -> error "incorrectly formatted defect line"
|
||||
|
||||
genericMain :: FilePath -> App ()
|
||||
genericMain file = do
|
||||
opts <- ask
|
||||
verbose Chatty $ show opts
|
||||
liftIO $ hSetBuffering stdin NoBuffering
|
||||
violations' <- liftIO $ filter (isRelevant (onlyNewest opts)) . parseViolations <$> readFile file
|
||||
|
||||
let mviolations = NE.nonEmpty violations'
|
||||
|
||||
case mviolations of
|
||||
Just violations -> do
|
||||
let sortedViolations = NE.sortBy reverseOccurrences violations
|
||||
groupedViolations = NE.groupBy ((==) `on` filename) sortedViolations
|
||||
verbose Chatty $ "all violations: " <> show sortedViolations
|
||||
forM_ groupedViolations handleViolations
|
||||
|
||||
Nothing -> do
|
||||
liftIO $ hPutStrLn stderr "Defects file is empty"
|
||||
|
||||
where
|
||||
reverseOccurrences :: Violation -> Violation -> Ordering
|
||||
reverseOccurrences = comparing filename <> flip (comparing line)
|
||||
|
||||
isRelevant :: Bool -> Violation -> Bool
|
||||
isRelevant newestOnly v
|
||||
| newestOnly = age v == Newest
|
||||
| otherwise = True
|
||||
|
||||
-- | handle violations within a single file
|
||||
handleViolations :: NonEmpty Violation -> App ()
|
||||
handleViolations violations = do
|
||||
opts <- ask
|
||||
let fname = filename $ NE.head violations
|
||||
fname' = fname <> ".fix"
|
||||
header' = "Processing " <> (show $ NE.length violations) <> " violation(s) in file " <> fname
|
||||
header = unlines
|
||||
[ header'
|
||||
, take (length header') $ repeat '='
|
||||
, ""
|
||||
]
|
||||
|
||||
fileExists <- liftIO $ doesFileExist fname
|
||||
|
||||
if fileExists
|
||||
then do
|
||||
liftIO $ hPutStrLn stderr header
|
||||
contents' <- liftIO $ readFile fname
|
||||
let !contents = id contents'
|
||||
|
||||
newContent <- foldlM handleViolation contents violations
|
||||
|
||||
liftIO $ writeFile fname' newContent
|
||||
|
||||
liftIO $ when (inplace opts) $ rename fname' fname
|
||||
else do
|
||||
verbose Low $ "skipping non-existent file " <> fname
|
||||
|
||||
|
||||
data UserChoice = Abort
|
||||
| Annotate Annotation
|
||||
| Skip
|
||||
| Help
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | let the user decide what to do with a violation
|
||||
getUserChoice :: Violation -> App UserChoice
|
||||
getUserChoice Violation{..} = do
|
||||
liftIO $ queryUser
|
||||
where queryUser = do
|
||||
putStr $ "> What shall we do [s/t/i/f/q/?]: "
|
||||
hFlush stdout
|
||||
c <- getChar
|
||||
putStrLn ""
|
||||
case c of
|
||||
's' -> do
|
||||
pure Skip
|
||||
't' -> do
|
||||
pure $ Annotate (ToDo rule)
|
||||
'i' -> do
|
||||
excuse <- getExcuse
|
||||
pure $ Annotate (FalsePositive rule excuse)
|
||||
'f' -> do
|
||||
excuse <- getExcuse
|
||||
pure $ Annotate (Intentional rule excuse)
|
||||
'q' -> pure Abort
|
||||
'?' -> do
|
||||
putStrLn $ unlines [ "t - add TODO marker to fix this issue"
|
||||
, "s - skip this violation"
|
||||
, "f - false positive"
|
||||
, "i - intentional"
|
||||
, "q - quit without changing the current file"
|
||||
, "? - show this help"
|
||||
]
|
||||
queryUser
|
||||
|
||||
_ -> queryUser
|
||||
|
||||
getExcuse = do
|
||||
putStr $ "What's your excuse? "
|
||||
hFlush stdout
|
||||
mode <- hGetBuffering stdin
|
||||
hSetBuffering stdin LineBuffering
|
||||
excuse <- getLine
|
||||
hSetBuffering stdin mode
|
||||
pure excuse
|
||||
|
||||
type Content = String
|
||||
type NumberedLine = (Int, String)
|
||||
|
||||
-- | merge lines together
|
||||
--
|
||||
-- It is assumed that both lists are sorted according to their line number
|
||||
-- @
|
||||
-- mergeLines [(1, "blah"), (2,"foo"), (2, "baz"), (3, "bam")] [(2,"bar")]
|
||||
-- [(1,"blah"),(2,"foo"),(2,"baz"),(2,"bar"),(3,"bam")]
|
||||
-- @
|
||||
mergeLines :: [NumberedLine] -> [NumberedLine] -> [NumberedLine]
|
||||
mergeLines [] r = r
|
||||
mergeLines l [] = l
|
||||
mergeLines !lhs@(left@(nl,_):ls) !rhs@(right@(nr,_):rs)
|
||||
| nl <= nr = left : mergeLines ls rhs
|
||||
| nl > nr = right : mergeLines lhs rs
|
||||
|
||||
-- | handle a single violation
|
||||
--
|
||||
-- The function gets the current content of the file and should result in the
|
||||
-- new content of the file
|
||||
handleViolation :: Content -> Violation -> App Content
|
||||
handleViolation content v@Violation{..} = do
|
||||
verbose Low $ show v
|
||||
opts <- ask
|
||||
|
||||
let (before, after) = splitAt (line-1) . zip [1..] . lines $ content
|
||||
context = getContext (contextLines opts) before after
|
||||
!indent = takeWhile isSpace (snd . head $ after)
|
||||
|
||||
-- print some context
|
||||
liftIO $ forM_ context (\(n, code) -> do
|
||||
let marker = '>' <$ indent
|
||||
when (n == line) $ putStrLn (intercalate " " [ marker
|
||||
, show age
|
||||
, "violation of rule"
|
||||
, show rule
|
||||
, "in line"
|
||||
, show line <> ":"
|
||||
, description
|
||||
])
|
||||
putStrLn (code))
|
||||
|
||||
|
||||
choice <- getUserChoice v
|
||||
case choice of
|
||||
Abort -> liftIO $ exitSuccess
|
||||
Annotate annotation -> do
|
||||
let !comment = showAnnotation annotation description
|
||||
!newContent = unlines . map snd $ (before ++ ((0, indent ++ comment) : after))
|
||||
pure newContent
|
||||
Skip -> pure content
|
||||
Help -> handleViolation content v
|
||||
|
||||
-- | Get some context around some line
|
||||
--
|
||||
-- the function receives the number of lines to show before and after a given line and the whole content split into lines before
|
||||
getContext :: Int -> [(Int, String)] -> [(Int, String)] -> [(Int, String)]
|
||||
getContext n before after = before' ++ after'
|
||||
where before' = reverse . take n . reverse $ before
|
||||
after' = take (n+1) after
|
||||
Loading…
Add table
Add a link
Reference in a new issue