Initial version

src/Annotator.hs

@@ -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

src/Annotator/Annotation.hs

@@ -0,0 +1,14 @@
+module Annotator.Annotation (Annotation(..), showAnnotation) where
+
+import Annotator.Rule
+import Data.Monoid
+
+data Annotation = Intentional !Rule !String
+                | FalsePositive !Rule !String
+                | ToDo !Rule
+                deriving (Show, Read, Eq)
+
+showAnnotation :: Annotation -> String -> String
+showAnnotation (Intentional (Rule rule) reason) _ = mconcat ["// ", "coverity[", rule, "_violation", "] ", reason]
+showAnnotation (FalsePositive (Rule rule) reason) _ = mconcat ["// ", "coverity[", rule, "_violation", " : FALSE", "] ", reason]
+showAnnotation (ToDo (Rule rule)) description = "// FIXME violation " <> rule <> ": " <> description

src/Annotator/Rule.hs

@@ -0,0 +1,10 @@
+{-# LANGUAGE InstanceSigs #-}
+
+module Annotator.Rule where
+
+newtype Rule = Rule String
+  deriving (Eq, Read)
+
+instance Show Rule where
+  show :: Rule -> String
+  show (Rule r) = r