diff --git a/data/Default.hs b/data/Default.hs --- a/data/Default.hs +++ b/data/Default.hs @@ -5,7 +5,7 @@ import Control.Monad import Data.Function import Data.Int -import Data.List +import Data.List as X import Data.Maybe import Data.Monoid import Data.Ord @@ -62,8 +62,6 @@ error "Use map once" = map f (map g x) ==> map (f . g) x warn = x !! 0 ==> head x error = take n (repeat x) ==> replicate n x -error = x ++ concatMap (' ':) y ==> unwords (x:y) -error = concat (intersperse " " x) ==> unwords x error = head (reverse x) ==> last x error = head (drop n x) ==> x !! n error = reverse (tail (reverse x)) ==> init x @@ -82,6 +80,10 @@ error = map (uncurry f) (zip x y) ==> zipWith f x y error = not (elem x y) ==> notElem x y warn = foldr f z (map g x) ==> foldr (f . g) z x +error = x ++ concatMap (' ':) y ==> unwords (x:y) +error = intercalate " " ==> unwords +warn = concat (intersperse x y) ==> intercalate x y where _ = notEq x " " +warn = concat (intersperse " " x) ==> unwords x -- FOLDS @@ -190,13 +192,13 @@ -- INFIX -warn "Use infix" = elem x y ==> x `elem` y where _ = not (isInfixApp original) && not (isParen result) -warn "Use infix" = notElem x y ==> x `notElem` y where _ = not (isInfixApp original) && not (isParen result) -warn "Use infix" = isInfixOf x y ==> x `isInfixOf` y where _ = not (isInfixApp original) && not (isParen result) -warn "Use infix" = isSuffixOf x y ==> x `isSuffixOf` y where _ = not (isInfixApp original) && not (isParen result) -warn "Use infix" = isPrefixOf x y ==> x `isPrefixOf` y where _ = not (isInfixApp original) && not (isParen result) -warn "Use infix" = union x y ==> x `union` y where _ = not (isInfixApp original) && not (isParen result) -warn "Use infix" = intersect x y ==> x `intersect` y where _ = not (isInfixApp original) && not (isParen result) +warn "Use infix" = X.elem x y ==> x `X.elem` y where _ = not (isInfixApp original) && not (isParen result) +warn "Use infix" = X.notElem x y ==> x `X.notElem` y where _ = not (isInfixApp original) && not (isParen result) +warn "Use infix" = X.isInfixOf x y ==> x `X.isInfixOf` y where _ = not (isInfixApp original) && not (isParen result) +warn "Use infix" = X.isSuffixOf x y ==> x `X.isSuffixOf` y where _ = not (isInfixApp original) && not (isParen result) +warn "Use infix" = X.isPrefixOf x y ==> x `X.isPrefixOf` y where _ = not (isInfixApp original) && not (isParen result) +warn "Use infix" = X.union x y ==> x `X.union` y where _ = not (isInfixApp original) && not (isParen result) +warn "Use infix" = X.intersect x y ==> x `X.intersect` y where _ = not (isInfixApp original) && not (isParen result) -- MATHS @@ -321,7 +323,8 @@ error = a $$$$ b $$$$ c ==> a . b $$$$$ c yes = when (not . null $ asdf) -- unless (null asdf) yes = id 1 -- 1 - +yes = case concat (map f x) of [] -> [] -- concatMap f x +yes = Map.union a b -- a `Map.union` b import Prelude \ yes = flip mapM -- Control.Monad.forM 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 +version: 1.8.1 -- license is GPL v2 only license: GPL license-file: LICENSE @@ -37,10 +37,8 @@ base == 4.*, process, filepath, directory, mtl, containers, hscolour == 1.17.*, cpphs == 1.11.*, - haskell-src-exts == 1.9.*, + haskell-src-exts == 1.9.* && >= 1.9.4, uniplate == 1.5.* - - ghc-options: -fno-warn-overlapping-patterns hs-source-dirs: src exposed-modules: diff --git a/hlint.htm b/hlint.htm --- a/hlint.htm +++ b/hlint.htm @@ -74,7 +74,7 @@

Acknowledgements

- This program has only been made possible by the presence of the haskell-src-exts package, and many improvements have been made by Niklas Broberg in response to feature requests. Additionally, many people have provided help and patches, including Lennart Augustsson, Malcolm Wallace, Henk-Jan van Tuyl, Gwern Branwen, Alex Ott, Andy Stewart and others. + This program has only been made possible by the presence of the haskell-src-exts package, and many improvements have been made by Niklas Broberg in response to feature requests. Additionally, many people have provided help and patches, including Lennart Augustsson, Malcolm Wallace, Henk-Jan van Tuyl, Gwern Branwen, Alex Ott, Andy Stewart, Roman Leshchinskiy and others.

Bugs and limitations

@@ -254,19 +254,19 @@

Ignore directives can also be written in the hint files:

diff --git a/src/Apply.hs b/src/Apply.hs --- a/src/Apply.hs +++ b/src/Apply.hs @@ -48,8 +48,9 @@ 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] + concat [order (fromNamed d) [i | h <- decHints, i <- h d] | d <- moduleDecls m] where + decHints = [h nm m | DeclHint h <- h] -- partially apply order n = map (\i -> i{func = (moduleName m,n)}) . sortBy (comparing loc) nm = moduleScope m @@ -61,13 +62,14 @@ classify :: [Setting] -> Idea -> Idea -classify xs i = if isParseError i then i else i{rank = foldl' (rerank i) (rank i) $ filter isClassify xs} +classify xs i = i{rank = foldl' (rerank i) (rank 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 + rerank i r c | matchHint (hintS c) (hint i) && matchFunc (funcS c) (func_ i) = rankS c | otherwise = r + func_ x = if isParseError x then ("","") else func x matchHint = (~=) matchFunc (x1,x2) (y1,y2) = (x1~=y1) && (x2~=y2) x ~= y = null x || x == y diff --git a/src/CmdLine.hs b/src/CmdLine.hs --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -1,6 +1,6 @@ {-# LANGUAGE PatternGuards #-} -module CmdLine(Cmd(..), getCmd, exitWithHelp) where +module CmdLine(Cmd(..), CppFlags(..), getCmd, exitWithHelp) where import Control.Monad import Data.List @@ -17,6 +17,12 @@ import Data.Version +data CppFlags + = NoCpp + | CppSimple + | Cpphs CpphsOptions + + -- FIXME: Hints vs GivenHints is horrible data Cmd = Cmd {cmdTest :: Bool -- ^ run in test mode? @@ -27,7 +33,7 @@ ,cmdIgnore :: [String] -- ^ the hints to ignore ,cmdShowAll :: Bool -- ^ display all skipped items ,cmdColor :: Bool -- ^ color the result - ,cmdCpphs :: Maybe CpphsOptions -- ^ options for cpphs + ,cmdCpp :: CppFlags -- ^ options for CPP ,cmdDataDir :: FilePath -- ^ the data directory ,cmdEncoding :: String -- ^ the text encoding ,cmdFindHints :: [FilePath] -- ^ source files to look for hints in @@ -46,6 +52,7 @@ | Color | Define String | Include String + | SimpleCpp | Ext String | DataDir String | Encoding String @@ -72,6 +79,7 @@ ,Option "q" ["quiet"] (NoArg Quiet) "Supress most console output" ,Option "" ["cpp-define"] (ReqArg Define "name[=value]") "CPP #define" ,Option "" ["cpp-include"] (ReqArg Include "dir") "CPP include path" + ,Option "" ["cpp-simple"] (NoArg SimpleCpp) "Use a simple CPP (strip # lines)" ] @@ -101,17 +109,20 @@ hints <- mapM (getHintFile dataDir) $ hintFiles ++ ["HLint" | null hintFiles] let givenHints = if null hintFiles then [] else hints + let languages = getExtensions [x | Language x <- opt] + let cpphs = defaultCpphsOptions {boolopts=defaultBoolOptions{hashline=False} ,includes = [x | Include x <- opt] ,defines = [(a,drop 1 b) | Define x <- opt, let (a,b) = break (== '=') x] } + let cpp | SimpleCpp `elem` opt = CppSimple -- must be first, so can disable CPP + | CPP `elem` languages = Cpphs cpphs + | otherwise = NoCpp let encoding = last $ "" : [x | Encoding x <- opt] when (encoding /= "") $ warnEncoding encoding - let languages = getExtensions [x | Language x <- opt] - return Cmd {cmdTest = test ,cmdFiles = files @@ -121,7 +132,7 @@ ,cmdIgnore = [x | Skip x <- opt] ,cmdShowAll = ShowAll `elem` opt ,cmdColor = Color `elem` opt - ,cmdCpphs = if CPP `elem` languages then Just cpphs else Nothing + ,cmdCpp = cpp ,cmdDataDir = dataDir ,cmdEncoding = encoding ,cmdFindHints = findHints diff --git a/src/HLint.hs b/src/HLint.hs --- a/src/HLint.hs +++ b/src/HLint.hs @@ -40,7 +40,7 @@ hlint :: [String] -> IO [Suggestion] hlint args = do cmd@Cmd{..} <- getCmd args - let flags = parseFlags{cpphs=cmdCpphs, encoding=cmdEncoding, language=cmdLanguage} + let flags = parseFlags{cppFlags=cmdCpp, encoding=cmdEncoding, language=cmdLanguage} if cmdTest then test (\x -> hlint x >> return ()) cmdDataDir cmdGivenHints >> return [] else if null cmdFiles && notNull cmdFindHints then diff --git a/src/HSE/All.hs b/src/HSE/All.hs --- a/src/HSE/All.hs +++ b/src/HSE/All.hs @@ -9,6 +9,8 @@ ) where import Util +import CmdLine +import Data.List import Data.Maybe import HSE.Util import HSE.Evaluate @@ -20,24 +22,30 @@ data ParseFlags = ParseFlags - {cpphs :: Maybe CpphsOptions + {cppFlags :: CppFlags ,language :: [Extension] ,encoding :: String ,infixes :: [Fixity] } parseFlags :: ParseFlags -parseFlags = ParseFlags Nothing defaultExtensions "" [] +parseFlags = ParseFlags NoCpp defaultExtensions "" [] parseFlagsNoLocations :: ParseFlags -> ParseFlags -parseFlagsNoLocations x = x{cpphs = fmap f $ cpphs x} +parseFlagsNoLocations x = x{cppFlags = case cppFlags x of Cpphs y -> Cpphs $ f y; y -> y} where f x = x{boolopts = (boolopts x){locations=False}} +runCpp :: CppFlags -> FilePath -> String -> IO String +runCpp NoCpp _ x = return x +runCpp CppSimple _ x = return $ unlines [if "#" `isPrefixOf` ltrim x then "" else x | x <- lines x] +runCpp (Cpphs o) file x = runCpphs o file x + + -- | Parse a Haskell module parseString :: ParseFlags -> FilePath -> String -> IO (String, ParseResult Module_) parseString flags file str = do - ppstr <- maybe return (`runCpphs` file) (cpphs flags) str + ppstr <- runCpp (cppFlags flags) file str return (ppstr, fmap (applyFixity fixity) $ parseFileContentsWithMode mode ppstr) where fixity = infixes flags ++ baseFixities diff --git a/src/HSE/Bracket.hs b/src/HSE/Bracket.hs --- a/src/HSE/Bracket.hs +++ b/src/HSE/Bracket.hs @@ -54,6 +54,7 @@ | isDotApp parent, isDotApp child, i == 1 = False | RecConstr{} <- parent = False | RecUpdate{} <- parent, i /= 0 = False + | Case{} <- parent, i /= 0 || isAnyApp child = False | Lambda{} <- parent, i == length (universeBi parent :: [Pat_]) - 1 = False -- watch out for PViewPat | otherwise = True diff --git a/src/HSE/Util.hs b/src/HSE/Util.hs --- a/src/HSE/Util.hs +++ b/src/HSE/Util.hs @@ -77,7 +77,6 @@ isMDo MDo{} = True; isMDo _ = False isBoxed Boxed{} = True; isBoxed _ = False isDerivDecl DerivDecl{} = True; isDerivDecl _ = False -isFunDep FunDep{} = True; isFunDep _ = False isPBangPat PBangPat{} = True; isPBangPat _ = False isPExplTypeArg PExplTypeArg{} = True; isPExplTypeArg _ = False isPFieldPun PFieldPun{} = True; isPFieldPun _ = False diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs --- a/src/Hint/Extensions.hs +++ b/src/Hint/Extensions.hs @@ -48,7 +48,7 @@ used :: Extension -> Module_ -> Bool used RecursiveDo = hasS isMDo used ParallelListComp = hasS isParComp -used FunctionalDependencies = hasS isFunDep +used FunctionalDependencies = hasT (un :: FunDep S) used ImplicitParams = hasT (un :: IPName S) used EmptyDataDecls = hasS f where f (DataDecl _ _ _ _ [] _) = True diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -38,7 +38,6 @@ import Data.Data import Unsafe.Coerce import Settings -import HSE.NameMatch import Hint.Type import Control.Monad import Control.Arrow @@ -88,7 +87,7 @@ let nm = nameMatch scope s u <- unifyExp nm lhs x u <- check u - let res = addBracket parent $ unqualify scope s $ performEval $ subst u rhs + let res = addBracket parent $ unqualify scope s u $ performEval $ subst u rhs guard $ checkSide side $ ("original",x) : ("result",res) : u guard $ checkDefine decl parent res return res @@ -112,6 +111,9 @@ unifyExp :: NameMatch -> Exp_ -> Exp_ -> Maybe [(String,Exp_)] unifyExp nm x y | isParen x || isParen y = unifyExp nm (fromParen x) (fromParen y) unifyExp nm (Var _ (fromNamed -> v)) y | isUnifyVar v = Just [(v,y)] +unifyExp nm (Var _ (Qual _ (ModuleName _ [m]) x)) (Var _ y) + | Qual _ (ModuleName _ m2) y <- y, y == x = Just [([m], Var an $ UnQual an $ Ident an m2)] + | UnQual _ y <- y, y == x = Just [([m], Var an $ UnQual an $ Ident an "")] unifyExp nm (Var _ x) (Var _ y) | nm x y = Just [] unifyExp nm x@(App _ x1 x2) (App _ y1 y2) = liftM2 (++) (unifyExp nm x1 y1) (unifyExp nm x2 y2) `mplus` @@ -205,8 +207,13 @@ -- contract Data.List.foo ==> foo, if Data.List is loaded -unqualify :: Scope -> Scope -> Exp_ -> Exp_ -unqualify from to = transformBi (nameQualify from to) +-- change X.foo => Module.foo, where X is looked up in the subst +unqualify :: Scope -> Scope -> [(String,Exp_)] -> Exp_ -> Exp_ +unqualify from to subs = transformBi f + where + f (Qual _ (ModuleName _ [m]) x) | Just y <- fmap fromNamed $ lookup [m] subs + = if null y then UnQual an x else Qual an (ModuleName an y) x + f x = nameQualify from to x addBracket :: Maybe (Int,Exp_) -> Exp_ -> Exp_ diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs --- a/src/Hint/Naming.hs +++ b/src/Hint/Naming.hs @@ -20,6 +20,7 @@ a -== b = 1 myTest = 1; my_test = 1 semiring'laws = 1 -- semiringLaws = ... +data Yes = FOO_A | Foo_B -- data Yes = FOO_A | FooB -} @@ -74,7 +75,7 @@ suggestName :: String -> Maybe String -suggestName x = listToMaybe [f x | not $ isSym x || good || "prop_" `isPrefixOf` x] +suggestName x = listToMaybe [f x | not $ isSym x || good || not (any isLower x) || "prop_" `isPrefixOf` x] where good = all isAlphaNum $ drp '_' $ drp '\'' $ reverse $ dropWhile (== '_') x drp x ys = if [x] `isPrefixOf` ys then tail ys else ys diff --git a/src/Hint/Structure.hs b/src/Hint/Structure.hs --- a/src/Hint/Structure.hs +++ b/src/Hint/Structure.hs @@ -16,7 +16,7 @@ | c <- f b = c foo x = yes x x where yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e foo x | otherwise = y -- foo x = y -foo x = x + x where -- foo x = x + x +-- FIXME: #358 foo x = x + x where -- foo x = x + x foo x | a = b | True = d -- foo x | a = b ; | otherwise = d -} @@ -51,7 +51,7 @@ | prettyPrint test `elem` ["otherwise","True"] = [gen "Redundant guard" $ Pattern pats (UnGuardedRhs an bod) bind] -hints gen (Pattern pats bod (Just bind)) | f bind +hints gen (Pattern pats bod (Just bind)) | f bind && False -- disabled due to bug 358 = [gen "Redundant where" $ Pattern pats bod Nothing] where f (BDecls _ x) = null x diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -195,22 +195,27 @@ reader x = readFile' $ "tests" pre <.> x flags <- - if has "flags" then fmap (takeWhile (/= '\n')) $ reader "flags" - else if has "hs" then return $ "tests/" ++ pre <.> "hs" - else if has "lhs" then return $ "tests/" ++ pre <.> "lhs" + if has "flags" then fmap lines $ reader "flags" + else if has "hs" then return ["tests/" ++ pre <.> "hs"] + else if has "lhs" then return ["tests/" ++ pre <.> "lhs"] else error "checkInputOutput, couldn't find or figure out flags" - -- Note: if main crashes (argument error etc) then it won't trap the ExitCode - got <- captureOutput $ handle (\(e::ExitCode) -> return ()) $ main $ words flags + got <- captureOutput $ + handle (\(e::SomeException) -> print $ e) $ + handle (\(e::ExitCode) -> return ()) $ + main flags want <- reader "output" - if got == want then return pass else do - (got,want) <- return (lines got, lines want) - let trail = replicate (max (length got) (length want)) "" - let (i,g,w):_ = [(i,g,w) | (i,g,w) <- zip3 [1..] (got++trail) (want++trail), g /= w] - putStrLn $ unlines - ["TEST FAILURE IN tests/" ++ pre - ,"DIFFER ON LINE: " ++ show i - ,"GOT : " ++ g - ,"WANT: " ++ w] - return failure + case got of + Nothing -> putStrLn "Warning: failed to capture output (GHC too old?)" >> return pass + Just got | got == want -> return pass + | otherwise -> do + (got,want) <- return (lines got, lines want) + let trail = replicate (max (length got) (length want)) "" + let (i,g,w):_ = [(i,g,w) | (i,g,w) <- zip3 [1..] (got++trail) (want++trail), g /= w] + putStrLn $ unlines + ["TEST FAILURE IN tests/" ++ pre + ,"DIFFER ON LINE: " ++ show i + ,"GOT : " ++ g + ,"WANT: " ++ w] + return failure diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -18,7 +18,9 @@ import Data.Generics.Uniplate.Operations import Language.Haskell.Exts.Extension +#if __GLASGOW_HASKELL__ >= 612 import GHC.IO.Handle(hDuplicate,hDuplicateTo) +#endif --------------------------------------------------------------------- @@ -141,7 +143,10 @@ -- FIXME: This could use a lot more bracket calls! -captureOutput :: IO () -> IO String +captureOutput :: IO () -> IO (Maybe String) +#if __GLASGOW_HASKELL__ < 612 +captureOutput act = return Nothing +#else captureOutput act = do tmp <- getTemporaryDirectory (f,h) <- openTempFile tmp "hlint" @@ -155,7 +160,8 @@ hDuplicateTo ste stderr res <- readFile' f removeFile f - return res + return $ Just res +#endif -- FIXME: Should use strict ByteString