diff --git a/hlint.cabal b/hlint.cabal --- a/hlint.cabal +++ b/hlint.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: hlint -version: 1.8.5 +version: 1.8.6 -- license is GPL v2 only license: GPL license-file: LICENSE diff --git a/src/Apply.hs b/src/Apply.hs --- a/src/Apply.hs +++ b/src/Apply.hs @@ -62,12 +62,12 @@ classify :: [Setting] -> Idea -> Idea -classify xs i = i{rank = foldl' (rerank i) (rank i) $ filter isClassify xs} +classify xs i = i{severity = foldl' (f i) (severity i) $ filter isClassify xs} where - -- figure out if we need to change the rank - rerank :: Idea -> Rank -> Setting -> Rank - rerank i r c | matchHint (hintS c) (hint i) && matchFunc (funcS c) (func_ i) = rankS c - | otherwise = r + -- figure out if we need to change the severity + f :: Idea -> Severity -> Setting -> Severity + f i r c | matchHint (hintS c) (hint i) && matchFunc (funcS c) (func_ i) = severityS c + | otherwise = r func_ x = if isParseError x then ("","") else func x matchHint = (~=) diff --git a/src/HLint.hs b/src/HLint.hs --- a/src/HLint.hs +++ b/src/HLint.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RecordWildCards #-} -module HLint(hlint, Suggestion, suggestionLocation) where +module HLint(hlint, Suggestion, suggestionLocation, suggestionSeverity, Severity(..)) where import Control.Monad import Data.List @@ -28,7 +28,12 @@ suggestionLocation = loc . fromSuggestion +-- | From a suggestion, determine how severe it is. +suggestionSeverity :: Suggestion -> Severity +suggestionSeverity = severity . fromSuggestion + + -- | This function takes a list of command line arguments, and returns the given suggestions. -- To see a list of arguments type @hlint --help@ at the console. -- This function writes to the stdout/stderr streams, unless @--quiet@ is specified. @@ -60,7 +65,7 @@ let settings = settings1 ++ settings2 ++ settings3 ideas <- fmap concat $ parallel [listM' =<< applyHint flags settings x | x <- cmdFiles] - let (showideas,hideideas) = partition (\i -> cmdShowAll || rank i /= Ignore) ideas + let (showideas,hideideas) = partition (\i -> cmdShowAll || severity i /= Ignore) ideas showItem <- if cmdColor then showANSI else return show mapM_ (outStrLn . showItem) showideas diff --git a/src/Hint/ListRec.hs b/src/Hint/ListRec.hs --- a/src/Hint/ListRec.hs +++ b/src/Hint/ListRec.hs @@ -44,10 +44,10 @@ f o = maybeToList $ do let x = o (x, addCase) <- findCase x - (use,rank,x) <- matchListRec x + (use,severity,x) <- matchListRec x let y = addCase x guard $ recursiveStr `notElem` vars y - return $ idea rank ("Use " ++ use) o y + return $ idea severity ("Use " ++ use) o y recursiveStr = "_recursive_" @@ -73,7 +73,7 @@ -- MATCH THE RECURSION -matchListRec :: ListCase -> Maybe (String,Rank,Exp_) +matchListRec :: ListCase -> Maybe (String,Severity,Exp_) matchListRec o@(ListCase vs nil (x,xs,cons)) | [] <- vs, nil ~= "[]", InfixApp _ lhs c rhs <- cons, opExp c ~= ":" diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -77,7 +77,7 @@ findIdeas :: [Setting] -> Scope -> Module S -> Decl_ -> [Idea] findIdeas matches s _ decl = - [ idea (rankS m) (hintS m) x y + [ idea (severityS m) (hintS m) x y | (parent,x) <- universeParentExp decl, not $ isParen x, let x2 = fmapAn x , m <- matches, Just y <- [matchIdea s decl m parent x2]] diff --git a/src/Idea.hs b/src/Idea.hs --- a/src/Idea.hs +++ b/src/Idea.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RecordWildCards, NoMonomorphismRestriction #-} -module Idea(module Idea, Rank(..)) where +module Idea(module Idea, Severity(..)) where import HSE.All import Settings @@ -10,8 +10,8 @@ data Idea - = Idea {func :: FuncName, rank :: Rank, hint :: String, loc :: SrcLoc, from :: String, to :: String} - | ParseError {rank :: Rank, hint :: String, loc :: SrcLoc, msg :: String, from :: String} + = Idea {func :: FuncName, severity :: Severity, hint :: String, loc :: SrcLoc, from :: String, to :: String} + | ParseError {severity :: Severity, hint :: String, loc :: SrcLoc, msg :: String, from :: String} deriving (Eq,Ord) @@ -29,7 +29,7 @@ showEx :: (String -> String) -> Idea -> String showEx tt Idea{..} = unlines $ - [showSrcLoc loc ++ " " ++ show rank ++ ": " ++ hint] ++ f "Found" from ++ f "Why not" to + [showSrcLoc loc ++ " " ++ show severity ++ ": " ++ hint] ++ f "Found" from ++ f "Why not" to where f msg x = (msg ++ ":") : map (" "++) (lines $ tt x) showEx tt ParseError{..} = unlines $ @@ -37,7 +37,7 @@ rawIdea = Idea ("","") -idea rank hint from to = rawIdea rank hint (toSrcLoc $ ann from) (f from) (f to) +idea severity hint from to = rawIdea severity hint (toSrcLoc $ ann from) (f from) (f to) where f = ltrim . prettyPrint warn = idea Warning err = idea Error diff --git a/src/Report.hs b/src/Report.hs --- a/src/Report.hs +++ b/src/Report.hs @@ -29,7 +29,7 @@ generateIds = map (head &&& length) . group . sort files = generateIds $ map (srcFilename . loc) ideas hints = generateIds $ map hintName ideas - hintName x = show (rank x) ++ ": " ++ hint x + hintName x = show (severity x) ++ ": " ++ hint x inner = [("VERSION",['v' : showVersion version]),("CONTENT",content), ("HINTS",list "hint" hints),("FILES",list "file" files)] @@ -51,7 +51,7 @@ writeIdea :: String -> Idea -> [String] writeIdea cls Idea{..} = ["
" - ,escapeHTML (showSrcLoc loc ++ " " ++ show rank ++ ": " ++ hint) ++ "
" + ,escapeHTML (showSrcLoc loc ++ " " ++ show severity ++ ": " ++ hint) ++ "
" ,"Found
" ,code from ,"Why not
" @@ -62,7 +62,7 @@ writeIdea cls ParseError{..} = ["
" - ,escapeHTML (showSrcLoc loc ++ " " ++ show rank ++ ": " ++ hint) ++ "
" + ,escapeHTML (showSrcLoc loc ++ " " ++ show severity ++ ": " ++ hint) ++ "
" ,"Error message
" ,"
" ++ escapeHTML msg ++ "
" ,"Code
" diff --git a/src/Settings.hs b/src/Settings.hs --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,7 +1,7 @@ {-# LANGUAGE PatternGuards, ViewPatterns #-} module Settings( - Rank(..), FuncName, Setting(..), isClassify, isMatchExp, + Severity(..), FuncName, Setting(..), isClassify, isMatchExp, defaultHintName, isUnifyVar, readSettings, readPragma, findSettings ) where @@ -16,15 +16,19 @@ defaultHintName = "Use alternative" -data Rank = Ignore | Warning | Error - deriving (Eq,Ord,Show) +-- | How severe an error is. +data Severity + = Ignore -- ^ Ignored errors are only returned when @--show@ is passed. + | Warning -- ^ Warnings are things that some people may consider improvements, but some may not. + | Error -- ^ Errors are suggestions that should nearly always be a good idea to apply. + deriving (Eq,Ord,Show,Read,Bounded,Enum) -getRank :: String -> Maybe Rank -getRank "ignore" = Just Ignore -getRank "warn" = Just Warning -getRank "warning" = Just Warning -getRank "error" = Just Error -getRank _ = Nothing +getSeverity :: String -> Maybe Severity +getSeverity "ignore" = Just Ignore +getSeverity "warn" = Just Warning +getSeverity "warning" = Just Warning +getSeverity "error" = Just Error +getSeverity _ = Nothing -- (modulename,functionname) @@ -45,8 +49,8 @@ -- TYPE data Setting - = Classify {rankS :: Rank, hintS :: String, funcS :: FuncName} - | MatchExp {rankS :: Rank, hintS :: String, scope :: Scope, lhs :: Exp_, rhs :: Exp_, side :: Maybe Exp_} + = Classify {severityS :: Severity, hintS :: String, funcS :: FuncName} + | MatchExp {severityS :: Severity, hintS :: String, scope :: Scope, lhs :: Exp_, rhs :: Exp_, side :: Maybe Exp_} | Builtin String -- use a builtin hint set | Infix Fixity deriving Show @@ -71,7 +75,7 @@ readHints :: FilePath -> FilePath -> IO [Either String Module_] readHints dataDir file = do y <- parseResult $ parseFile (addInfix parseFlags) file - ys <- concatM [f $ fromNamed $ importModule i | i <- moduleImports y, importPkg i == Just "hint"] + ys <- concatM [f $ fromNamed $ importModule i | i <- moduleImports y, importPkg i `elem` [Just "hint", Just "hlint"]] return $ Right y:ys where f x | "HLint.Builtin." `isPrefixOf` x = return [Left $ drop 14 x] @@ -80,10 +84,10 @@ readSetting :: Scope -> Decl_ -> [Setting] -readSetting s (FunBind _ [Match _ (Ident _ (getRank -> Just rank)) pats (UnGuardedRhs _ bod) bind]) +readSetting s (FunBind _ [Match _ (Ident _ (getSeverity -> Just severity)) pats (UnGuardedRhs _ bod) bind]) | InfixApp _ lhs op rhs <- bod, opExp op ~= "==>" = - [MatchExp rank (if null names then defaultHintName else head names) s (fromParen lhs) (fromParen rhs) (readSide $ childrenBi bind)] - | otherwise = [Classify rank n func | n <- names2, func <- readFuncs bod] + [MatchExp severity (if null names then defaultHintName else head names) s (fromParen lhs) (fromParen rhs) (readSide $ childrenBi bind)] + | otherwise = [Classify severity n func | n <- names2, func <- readFuncs bod] where names = filter notNull $ getNames pats bod names2 = ["" | null names] ++ names @@ -105,9 +109,9 @@ f (ModuleAnn _ x) = g "" x g name (Lit _ (String _ s _)) | "hlint:" `isPrefixOf` map toLower s = - case getRank a of + case getSeverity a of Nothing -> errorOn o "bad classify pragma" - Just rank -> Just $ Classify rank (ltrim b) ("",name) + Just severity -> Just $ Classify severity (ltrim b) ("",name) where (a,b) = break isSpace $ ltrim $ drop 6 s readPragma _ = Nothing diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -154,7 +154,7 @@ | not good] match "???" _ = True - match x y | "@" `isPrefixOf` x = a == show (rank y) && match (ltrim b) y + match x y | "@" `isPrefixOf` x = a == show (severity y) && match (ltrim b) y where (a,b) = break isSpace $ tail x match x y = on (==) norm (to y) x