jakalx/annotator
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fix all found hlint hints

Browse source
This commit is contained in:
Alexander Kobjolke 2023-01-06 15:17:10 +01:00
parent c9b6ad7427
commit c70ce7c1d8
3 changed files with 45 additions and 53 deletions
Download patch file Download diff file Expand all files Collapse all files

95
src/Annotator.hs
View file

@ -1,7 +1,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE StrictData #-}
module Annotator (defaultMain) where
@ -17,7 +16,7 @@ import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Control.Exception (evaluate)
import Data.Function (on)
import Data.List (delete, intercalate, foldl', sortBy, nub)
import Data.List (delete, foldl', sortOn, nub)
import Data.Char (isSpace)
import Data.Either (rights)
import Data.Ord
@ -104,7 +103,7 @@ options =
(ReqArg (\f opts -> opts { todoMarker = f }) "STRING")
"override the default TODO marker with a custom string"
, Option ['A'] ["annotations"]
(ReqArg (\f opts -> opts { annotationFiles = (nub $ annotationFiles opts ++ [f]) }) "FILE")
(ReqArg (\f opts -> opts { annotationFiles = f : annotationFiles opts }) "FILE")
(unlines [ "load automatic annotation rules"
, " some examples:"
, " " <> show (Intentional (Rule "rule_1") "some reason")
@ -124,7 +123,9 @@ readMaybe s = case reads s of
parseOptions :: [String] -> IO (Options, [String])
parseOptions argv =
case getOpt Permute options argv of
(o, n, []) -> pure (foldl' (flip id) defaultOptions o, n)
(o, n, []) -> do
let o' = foldl' (flip id) defaultOptions o
pure (o'{annotationFiles = reverse $ nub $ annotationFiles o'}, n)
(_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options))
where
header = "Usage: annotator [OPTIONS] files..."
@ -145,18 +146,18 @@ defaultMain = do
Just FullVersion -> do
putStr $ unlines
[
"Annotator v" <> (Vsn.showVersion version)
"Annotator v" <> Vsn.showVersion version
, "Copyright (c) 2022 Alexander Kobjolke <alexander.kobjolke@atlas-elektronik.com>"
]
exitWith ExitSuccess
exitSuccess
Just ShortVersion -> do
putStrLn $ Vsn.showVersion version
exitWith ExitSuccess
exitSuccess
Nothing -> pure ()
when (showHelp opts) $ do
putStr $ usageInfo header options
exitWith ExitSuccess
exitSuccess
automaticAnnotations <- rights . concat <$> (filterM fileExist (annotationFiles opts) >>= mapM fromFile)
@ -165,9 +166,8 @@ defaultMain = do
runReaderT (genericMain fn) opts'
where
header = unlines $
[
"Usage: annotator [OPTIONS] files..."
header = unlines
[ "Usage: annotator [OPTIONS] files..."
, ""
, "A tool to semi-automatically add Coverity source-code annotations based on found defects."
, ""
@ -177,11 +177,11 @@ data Age = Old | New | Newest
deriving (Show, Eq)
data Violation = Violation {
filename :: !FilePath,
line :: !Int,
age :: !Age,
rule :: !Rule,
description :: !String
filename :: FilePath,
line :: Int,
age :: Age,
rule :: Rule,
description :: String
}
deriving (Show, Eq)
@ -190,7 +190,7 @@ split _ _ [] = []
split n p xs
| n > 0 = case break p xs of
(match, []) -> [match]
(match, (_ : rest)) -> match : split (n-1) p rest
(match, _ : rest) -> match : split (n-1) p rest
| otherwise = [xs]
parseViolations :: String -> [Violation]
@ -208,7 +208,7 @@ parseViolation s = case split 4 (== ':') s of
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
a = case delete ',' age' of
"Newest" -> Newest
"New" -> New
_ -> Old
@ -230,7 +230,7 @@ genericMain file = do
verbose Chatty $ "all violations: " <> show sortedViolations
forM_ groupedViolations handleViolations
Nothing -> do
Nothing ->
liftIO $ hPutStrLn stderr "Defects file is empty"
where
@ -249,10 +249,10 @@ handleViolations violations = do
let fname = filename $ NE.head violations
fname' = fname <> ".fix"
todo = todoMarker opts
header' = "Processing " <> (show $ NE.length violations) <> " violation(s) in file " <> fname
header' = "Processing " <> show (NE.length violations) <> " violation(s) in file " <> fname
header = unlines
[ header'
, take (length header') $ repeat '='
, replicate (length header') '='
, ""
]
@ -268,15 +268,15 @@ handleViolations violations = do
let numberedContent = zip [1..] . lines $ content
annotations <- (catMaybes . NE.toList) <$> mapM (handleViolation content) violations
annotations <- catMaybes . NE.toList <$> mapM (handleViolation content) violations
let annotatedLines = sortBy (comparing fst) $ fmap (annotationToLine todo) annotations
let annotatedLines = sortOn fst $ fmap (annotationToLine todo) annotations
newContent = unlines . map snd $ mergeLines annotatedLines numberedContent
liftIO $ writeFile fname' newContent
liftIO $ when (inplace opts) $ rename fname' fname
else do
else
verbose Low $ "skipping non-existent file " <> fname
where
annotationToLine :: String -> AnnotatedViolation -> (Int, String)
@ -296,24 +296,17 @@ data UserChoice = Abort
-- | let the user decide what to do with a violation
getUserChoice :: Violation -> App UserChoice
getUserChoice Violation{..} = do
liftIO $ queryUser
getUserChoice Violation{..} = liftIO queryUser
where queryUser = do
putStr $ "> What shall we do [s/t/i/f/q/?]: "
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 (Intentional rule excuse)
'f' -> do
excuse <- getExcuse
pure $ Annotate (FalsePositive rule excuse)
's' -> pure Skip
't' -> pure $ Annotate (ToDo rule)
'i' -> Annotate . Intentional rule <$> getExcuse
'f' -> Annotate . FalsePositive rule <$> getExcuse
'q' -> pure Abort
'?' -> do
putStrLn $ unlines [ "t - add TODO marker to fix this issue"
@ -328,7 +321,7 @@ getUserChoice Violation{..} = do
_ -> queryUser
getExcuse = do
putStr $ "What's your excuse? "
putStr "What's your excuse? "
hFlush stdout
mode <- hGetBuffering stdin
hSetBuffering stdin LineBuffering
@ -349,7 +342,7 @@ type NumberedLine = (Int, String)
mergeLines :: [NumberedLine] -> [NumberedLine] -> [NumberedLine]
mergeLines [] r = r
mergeLines l [] = l
mergeLines !lhs@(left@(nl,_):ls) !rhs@(right@(nr,_):rs)
mergeLines lhs@(left@(nl,_):ls) rhs@(right@(nr,_):rs)
| nl <= nr = left : mergeLines ls rhs
| otherwise = right : mergeLines lhs rs
@ -379,21 +372,21 @@ handleViolation content v@Violation{..} = do
-- print some context
liftIO $ forM_ context (\(n, code) -> do
let marker = ">>>>"
when (n == line) $ putStrLn (intercalate " " [ marker
, show age
, "violation of rule"
, show rule
, "in line"
, show line <> ":"
, description
])
putStrLn (code))
when (n == line) $ putStrLn (unwords [ marker
, show age
, "violation of rule"
, show rule
, "in line"
, show line <> ":"
, description
])
putStrLn code)
if batchMode opts
then pure $ Nothing
then pure Nothing
else do
choice <- getUserChoice v
case choice of
Abort -> liftIO $ exitSuccess
Abort -> liftIO exitSuccess
Annotate annotation -> pure $ Just (AnnotatedViolation v annotation indent)
Skip -> pure Nothing
Help -> handleViolation content v

1
src/Annotator/Annotation.hs
View file

@ -1,4 +1,3 @@
{-# LANGUAGE LambdaCase #-}
module Annotator.Annotation (Annotation(..), fromFile) where
import Data.Char (isSpace)

2
src/Annotator/Util.hs
View file

@ -1,4 +1,4 @@
module Annotator.Util where
anyp :: [a -> Bool] -> a -> Bool
anyp preds x = or (map ($ x) preds)
anyp preds x = any ($ x) preds