hlint 1.6.17 → 1.6.18
raw patch · 10 files changed
+104/−56 lines, 10 filesdep ~cpphsdep ~hscolourPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: cpphs, hscolour
API changes (from Hackage documentation)
Files
- data/Default.hs +3/−2
- data/Test.hs +4/−4
- hlint.cabal +3/−3
- hlint.htm +11/−1
- src/HSE/All.hs +12/−5
- src/Hint.hs +35/−17
- src/Settings.hs +13/−12
- src/Test.hs +12/−11
- src/Type.hs +2/−1
- src/Util.hs +9/−0
data/Default.hs view
@@ -227,9 +227,11 @@ error "Use isPrefixOf" = (take i s == t) ==> _eval_ ((i == length t) && (t `Data.List.isPrefixOf` s)) where _ = (isList t || isLit t) && isLit i +{-+-- clever hint, but not actually a good idea warn = (do a <- f; g a) ==> f >>= g where _ = (isAtom f || isApp f) && notIn a g-+-} {-@@ -255,7 +257,6 @@ yes = head (reverse xs) -- last xs yes = reverse xs `isPrefixOf` reverse ys -- isSuffixOf xs ys no = putStrLn $ show (length xs) ++ "Test"-yes = do line <- getLine; putStrLn line -- getLine >>= putStrLn yes = ftable ++ map (\ (c, x) -> (toUpper c, urlEncode x)) ftable -- toUpper Control.Arrow.*** urlEncode yes = map (\(a,b) -> a) xs -- fst yes = map (\(a,_) -> a) xs -- fst
data/Test.hs view
@@ -23,10 +23,10 @@ warn = ignoreTest3 ignore = Ignore_Test -{-# WARNING module_ "HLint: ignore Test4" #-}-{-# WARNING annTest2 "HLint: error" #-}-{-# WARNING annTest3 "HLint: warn" #-}-{-# WARNING Ann_Test "HLint: ignore" #-}+{-# ANN module "HLint: ignore Test4" #-}+{-# ANN annTest2 "HLint: error" #-}+{-# ANN annTest3 "HLint: warn" #-}+{-# ANN type Ann_Test "HLint: ignore" #-} error = concat (map f x) ==> Data.List.concatMap f x
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: hlint-version: 1.6.17+version: 1.6.18 -- license is GPL v2 only license: GPL license-file: LICENSE@@ -35,8 +35,8 @@ library build-depends: base == 4.*, process, filepath, directory, mtl, containers,- hscolour == 1.15.*,- cpphs == 1.10.*,+ hscolour == 1.16.*,+ cpphs == 1.11.*, haskell-src-exts == 1.8.*, uniplate == 1.5.*
hlint.htm view
@@ -246,7 +246,17 @@ <h3>Ignoring hints</h3> <p>- Some of the hints are subjective, and some users believe they should be ignored. Some hints are applicable usually, but occasionally don't always make sense. The ignoring mechanism provides features for supressing certain hints. Ignore directives are picked up from the hint files. Some example directives are:+ Some of the hints are subjective, and some users believe they should be ignored. Some hints are applicable usually, but occasionally don't always make sense. The ignoring mechanism provides features for supressing certain hints. <!-- Ignore directives can either be written as pragmas in the file being analysed, or in the hint files. Examples of pragmas are:+</p>+<ul>+ <li><tt>{-# ANN module "HLint: ignore Eta reduce" #-}</tt> - ignore all eta reduction suggestions in this module.</li>+ <li><tt>{-# ANN map "HLint: ignore" #-}</tt> - don't give any hints in the function map.</li>+ <li><tt>{-# ANN map "HLint: error" #-}</tt> - any hint in the function is an error.</li>+ <li><tt>{-# ANN module "HLint: error Use concatMap" #-}</tt> - the hint to use concatMap is an error.</li>+ <li><tt>{-# ANN warn "HLint: Use concatMap" #-}</tt> - the hint to use concatMap is a warning.</li>+</ul>+<p> -->+ Ignore directives can also be written in the hint files: </p> <ul> <li><tt>ignore "Eta reduce"</tt> - supress all eta reduction suggestions.</li>
src/HSE/All.hs view
@@ -4,7 +4,8 @@ module HSE.Bracket, module HSE.Match, module HSE.Type, module HSE.Eq, module HSE.NameMatch,- ParseFlags(..), parseFlags, parseFile, parseString+ ParseFlags(..), parseFlags, parseFlagsNoLocations,+ parseFile, parseString ) where import Util@@ -28,10 +29,16 @@ parseFlags :: ParseFlags parseFlags = ParseFlags Nothing False "" +parseFlagsNoLocations :: ParseFlags -> ParseFlags+parseFlagsNoLocations x = x{cpphs = fmap f $ cpphs x}+ where f x = x{boolopts = (boolopts x){locations=False}} + -- | Parse a Haskell module-parseString :: ParseFlags -> FilePath -> String -> ParseResult Module_-parseString flags file = parseFileContentsWithMode mode . maybe id (`runCpphs` file) (cpphs flags)+parseString :: ParseFlags -> FilePath -> String -> IO (String, ParseResult Module_)+parseString flags file str = do+ ppstr <- maybe return (`runCpphs` file) (cpphs flags) str+ return (ppstr, parseFileContentsWithMode mode ppstr) where mode = defaultParseMode {parseFilename = file@@ -41,10 +48,10 @@ } -parseFile :: ParseFlags -> FilePath -> IO (ParseResult Module_)+parseFile :: ParseFlags -> FilePath -> IO (String, ParseResult Module_) parseFile flags file = do src <- readFileEncoding (encoding flags) file- return $ parseString flags file src+ parseString flags file src extension = knownExtensions \\ badExtensions
src/Hint.hs view
@@ -20,22 +20,40 @@ applyHint :: ParseFlags -> [Hint] -> [Setting] -> FilePath -> IO [Idea] applyHint flags h s file = do src <- readFileEncoding (encoding flags) file- return $ applyHintStr flags h s file src+ applyHintStr flags h s file src -applyHintStr :: ParseFlags -> [Hint] -> [Setting] -> FilePath -> String -> [Idea]-applyHintStr flags h s file src =- case parseString flags file src of- ParseFailed sl msg ->- let ticks = [" "," ","> "," "," "]- bad = zipWith (++) ticks $ take 5 $ drop (srcLine sl - 3) $ lines src ++ [""]- bad2 = reverse $ dropWhile (all isSpace) $ reverse $ dropWhile (all isSpace) bad- in [classify s $ ParseError Warning "Parse error" sl msg (unlines bad2)]- ParseOk m ->- let name = moduleName m- nm = nameMatch $ moduleImports m- order n = map (\i -> i{func = (name,n)}) . sortBy (comparing loc)- settings = concatMap(fromMaybe [] . readPragma) $ moduleDecls m- in map (classify $ s ++ settings) $- order "" [i | ModuHint h <- h, i <- h nm m] ++- concat [order (fromNamed d) [i | DeclHint h <- h, i <- h nm m d] | d <- moduleDecls m]+applyHintStr :: ParseFlags -> [Hint] -> [Setting] -> FilePath -> String -> IO [Idea]+applyHintStr flags h s file src = do+ res <- parseString flags file src+ case snd res of+ ParseFailed sl msg -> map (classify s) `fmap` parseFailed flags sl msg src+ ParseOk m -> return $+ let settings = mapMaybe readPragma $ moduleDecls m+ in map (classify $ s ++ settings) $ parseOk h m+++parseFailed :: ParseFlags -> SrcLoc -> String -> String -> IO [Idea]+parseFailed flags sl msg src = do+ -- figure out the best line number to grab context from, by reparsing+ (str2,pr2) <- parseString (parseFlagsNoLocations flags) "" src+ let ctxt = case pr2 of+ ParseFailed sl2 _ -> context (srcLine sl2) str2+ _ -> context (srcLine sl) src+ return [ParseError Warning "Parse error" sl msg ctxt]+++context :: Int -> String -> String+context lineNo src =+ unlines $ trimBy (all isSpace) $+ zipWith (++) ticks $ take 5 $ drop (lineNo - 3) $ lines src ++ [""]+ where ticks = [" "," ","> "," "," "]+++parseOk :: [Hint] -> Module_ -> [Idea]+parseOk h m =+ order "" [i | ModuHint h <- h, i <- h nm m] +++ concat [order (fromNamed d) [i | DeclHint h <- h, i <- h nm m d] | d <- moduleDecls m]+ where+ order n = map (\i -> i{func = (moduleName m,n)}) . sortBy (comparing loc)+ nm = nameMatch $ moduleImports m
src/Settings.hs view
@@ -23,7 +23,7 @@ -- currently it doesn't readHints :: FilePath -> FilePath -> IO [Either String Module_] readHints dataDir file = do- y <- fromParseResult `fmap` parseFile parseFlags{implies=True} file+ y <- (fromParseResult . snd) `fmap` parseFile parseFlags{implies=True} file ys <- concatMapM (f . fromNamed . importModule) $ moduleImports y return $ Right y:ys where@@ -60,25 +60,26 @@ names = getNames pats bod names2 = ["" | null names] ++ names -readSetting x@WarnPragmaDecl{} | Just y <- readPragma x = y+readSetting x@AnnPragma{} | Just y <- readPragma x = [y] readSetting (PatBind an (PVar _ name) _ bod bind) = readSetting $ FunBind an [Match an name [PLit an (String an "" "")] bod bind] readSetting (FunBind an xs) | length xs /= 1 = concatMap (readSetting . FunBind an . return) xs readSetting (SpliceDecl an (App _ (Var _ x) (Lit _ y))) = readSetting $ FunBind an [Match an (toNamed $ fromNamed x) [PLit an y] (UnGuardedRhs an $ Lit an $ String an "" "") Nothing] readSetting x = errorOn x "bad hint" --- FIXME: Want to use ANN rather than WARNING, but need HSE support -- return Nothing if it is not an HLint pragma, otherwise all the settings-readPragma :: Decl_ -> Maybe [Setting]-readPragma x@(WarnPragmaDecl _ [(names,warn)])- | not $ "HLint:" `isPrefixOf` warn = Nothing- | Just rank <- getRank a = Just $ map (Classify rank (dropWhile isSpace b)) ns2- | otherwise = errorOn x "bad classify pragma"- where ns = if null names then [""] else map fromNamed names- ns2 = [if n == "module_" then ("","") else ("",n) | n <- ns]- (a,b) = break isSpace $ dropWhile isSpace $ drop 6 warn+readPragma :: Decl_ -> Maybe Setting+readPragma o@(AnnPragma _ p) = f p+ where+ f (Ann _ name x) = g (fromNamed name) x+ f (TypeAnn _ name x) = g (fromNamed name) x+ f (ModuleAnn _ x) = g "" x -readPragma (WarnPragmaDecl an xs) = concatMapM (readPragma . WarnPragmaDecl an . return) xs+ g name (Lit _ (String _ s _)) | "hlint:" `isPrefixOf` map toLower s =+ case getRank a of+ Nothing -> errorOn o "bad classify pragma"+ Just rank -> Just $ Classify rank (ltrim b) ("",name)+ where (a,b) = break isSpace $ ltrim $ drop 6 s readPragma _ = Nothing
src/Test.hs view
@@ -17,6 +17,7 @@ import Settings import Type+import Util import Hint import HSE.All import Hint.All@@ -91,28 +92,28 @@ runTest :: [Setting] -> [Hint] -> FilePath -> IO (Int,Int) runTest setting hint file = do tests <- parseTestFile file- let failures = concatMap f tests+ failures <- concatMapM f tests putStr $ unlines failures return (length failures, length tests) where- f (Test loc inp out) =+ f (Test loc inp out) = do+ ideas <- applyHintStr parseFlags hint setting file inp+ let good = case out of+ Nothing -> null ideas+ Just x -> length ideas == 1 &&+ length (show ideas) >= 0 && -- force, mainly for hpc+ not (isParseError (head ideas)) &&+ match x (head ideas)+ return ["TEST FAILURE (" ++ show (length ideas) ++ " hints generated)\n" ++ "SRC: " ++ showSrcLoc loc ++ "\n" ++ "INPUT: " ++ inp ++ "\n" ++ concatMap ((++) "OUTPUT: " . show) ideas ++ "WANTED: " ++ fromMaybe "<failure>" out ++ "\n\n" | not good]- where- ideas = applyHintStr parseFlags hint setting file inp- good = case out of- Nothing -> null ideas- Just x -> length ideas == 1 &&- length (show ideas) >= 0 && -- force, mainly for hpc- not (isParseError (head ideas)) &&- match x (head ideas) match "???" _ = True- match x y | "@" `isPrefixOf` x = a == show (rank y) && match (dropWhile isSpace b) y+ match x y | "@" `isPrefixOf` x = a == show (rank y) && match (ltrim b) y where (a,b) = break isSpace $ tail x match x y = on (==) norm (to y) x
src/Type.hs view
@@ -6,6 +6,7 @@ import Data.Char import Language.Haskell.HsColour.TTY import Language.Haskell.HsColour.Colourise+import Util ---------------------------------------------------------------------@@ -61,7 +62,7 @@ rawIdea = Idea ("","") idea rank hint from to = rawIdea rank hint (toSrcLoc $ ann from) (f from) (f to)- where f = dropWhile isSpace . prettyPrint+ where f = ltrim . prettyPrint warn = idea Warning err = idea Error
src/Util.hs view
@@ -4,6 +4,7 @@ import Control.Arrow import Control.Monad+import Data.Char import Data.Function import Data.List import Data.Ord@@ -97,3 +98,11 @@ exitMessage msg = unsafePerformIO $ do putStrLn msg exitWith $ ExitFailure 1+++ltrim :: String -> String+ltrim = dropWhile isSpace+++trimBy :: (a -> Bool) -> [a] -> [a]+trimBy f = reverse . dropWhile f . reverse . dropWhile f