+ To run HLint on n processors append the flags +RTS -Nn, as described in the GHC user manual. HLint will usually perform fastest if n is equal to the number of physical processors. +
+- As an example, to check the file Example.hs with both the default hints and the dollar hint, I could type: hlint Example.hs --hint Default --hint Dollar. Alternatively, I could create the file HLint.hs in the working directory and give it the contents: + As an example, to check the file Example.hs with both the default hints and the dollar hint, I could type: hlint Example.hs --hint=Default --hint=Dollar. Alternatively, I could create the file HLint.hs in the working directory and give it the contents:
import HLint.Default @@ -216,7 +222,7 @@ error = concat (map f x) ==> concatMap f x
- The line can be read as replace concat (map f x) with concat (map f x). Anything with a 1-letter variable is treated as a substitution parameter. For examples of more complex hints see the supplied hints file. In general, hints should not be given in point free style, as this reduces the power of the matching. Hints may start with error or warn to denote how severe they are by default. + The line can be read as replace concat (map f x) with concatMap f x. Anything with a 1-letter variable is treated as a substitution parameter. For examples of more complex hints see the supplied hints file. In general, hints should not be given in point free style, as this reduces the power of the matching. Hints may start with error or warn to denote how severe they are by default.
If you come up with interesting hints, please submit them. For example, some of the hints about last were supplied by Henning Thielemann.
diff --git a/src/CmdLine.hs b/src/CmdLine.hs --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -9,7 +9,6 @@ import System.Environment import System.Exit import System.FilePath -import HSE.All import Util import Paths_hlint @@ -87,10 +86,9 @@ [versionText ," hlint [files/directories] [options]" ,usageInfo "" opts - ,"HLint makes hints on how to improve some Haskell code." + ,"HLint gives hints on how to improve Haskell code." ,"" - ,"For example, to check all .hs and .lhs files in the folder src and" - ,"generate a report:" + ,"To check all Haskell files in 'src' and generate a report type:" ," hlint src --report" ] diff --git a/src/HSE/All.hs b/src/HSE/All.hs --- a/src/HSE/All.hs +++ b/src/HSE/All.hs @@ -3,11 +3,12 @@ module Language.Haskell.Exts, module HSE.Util, module HSE.Evaluate, module HSE.Bracket, module HSE.Match, - module HSE.Operators, module HSE.Generics, - parseFile, parseString + module HSE.Generics, + module HSE.NameMatch, + parseFile, parseString, fromParseResult ) where -import Language.Haskell.Exts hiding (parseFile, paren) +import Language.Haskell.Exts hiding (parse, parseFile, paren, fromParseResult) import qualified Language.Haskell.Exts as HSE import HSE.Util @@ -15,30 +16,54 @@ import HSE.Generics import HSE.Bracket import HSE.Match -import HSE.Operators +import HSE.NameMatch import Util -import System.IO.Unsafe(unsafeInterleaveIO) +import Data.Char +import Data.List +-- | Parse a Haskell module +parseString :: FilePath -> String -> ParseResult Module +parseString file = parseFileContentsWithMode mode . unlines . map f . lines + where + f x | "#" `isPrefixOf` dropWhile isSpace x = "" + | otherwise = x + + mode = defaultParseMode + {parseFilename = file + ,extensions = extension + ,fixities = infix_ (-1) ["==>"] ++ baseFixities + } + + -- | On failure returns an empty module and prints to the console -parseFile :: FilePath -> IO Module -parseFile file = unsafeInterleaveIO $ do - res <- HSE.parseFile file - case res of - ParseOk x -> return $ hlintFixities x - ParseFailed src msg -> do - putStrLn $ showSrcLoc src ++ " Parse failure, " ++ limit 50 msg - return $ Module nullSrcLoc (ModuleName "") [] Nothing Nothing [] [] +parseFile :: FilePath -> IO (ParseResult Module) +parseFile file = do + src <- readFile file + return $ parseString file src --- | On failure crashes -parseString :: String -> String -> Module -parseString file src = - case parseFileContentsWithMode (ParseMode file) src of - ParseOk x -> hlintFixities x - _ -> error $ "Parse failure in " ++ file ++ "\n" ++ src +-- | TODO: Use the fromParseResult in HSE once it gives source location +fromParseResult :: ParseResult Module -> Module +fromParseResult (ParseOk x) = x +fromParseResult (ParseFailed src msg) = error $ showSrcLoc src ++ " Parse failure, " ++ limit 50 msg -hlintFixities :: Module -> Module -hlintFixities = applyFixities (infix_ (-1) ["==>"] ++ baseFixities) +extension = + [OverlappingInstances, UndecidableInstances, IncoherentInstances, RecursiveDo + ,ParallelListComp, MultiParamTypeClasses, NoMonomorphismRestriction, FunctionalDependencies + ,Rank2Types, RankNTypes, PolymorphicComponents, ExistentialQuantification, ScopedTypeVariables + ,ImplicitParams,FlexibleContexts,FlexibleInstances,EmptyDataDecls + -- NOT: CPP + ,KindSignatures,BangPatterns,TypeSynonymInstances,TemplateHaskell + ,ForeignFunctionInterface,Arrows,Generics,NoImplicitPrelude,NamedFieldPuns,PatternGuards + ,GeneralizedNewtypeDeriving,ExtensibleRecords,RestrictedTypeSynonyms,HereDocuments + ,MagicHash,TypeFamilies,StandaloneDeriving,UnicodeSyntax,PatternSignatures,UnliftedFFITypes + ,LiberalTypeSynonyms,TypeOperators,RecordWildCards,RecordPuns,DisambiguateRecordFields + ,OverloadedStrings,GADTs,MonoPatBinds,RelaxedPolyRec,ExtendedDefaultRules,UnboxedTuples + ,DeriveDataTypeable,ConstrainedClassMethods,PackageImports,ImpredicativeTypes + ,NewQualifiedOperators,PostfixOperators,QuasiQuotes,ViewPatterns + -- NOT: TransformListComp - steals the group keyword + -- NOT: XmlSyntax, RegularPatterns - steals a-b + ] diff --git a/src/HSE/Bracket.hs b/src/HSE/Bracket.hs --- a/src/HSE/Bracket.hs +++ b/src/HSE/Bracket.hs @@ -3,9 +3,7 @@ module HSE.Bracket where import Control.Monad.State -import Data.Generics import Data.Generics.PlateData -import Data.List import Data.Maybe import Language.Haskell.Exts import HSE.Util @@ -40,10 +38,11 @@ needBracket :: Int -> Exp -> Exp -> Bool needBracket i parent child | isAtom child = False - | isInfixApp parent, isApp child = False - | isListComp parent = False - | isIf parent, isAnyApp child = False - | isApp parent, i == 0, isApp child = False + | InfixApp{} <- parent, isApp child = False + | ListComp{} <- parent = False + | If{} <- parent, isAnyApp child = False + | App{} <- parent, i == 0, isApp child = False + | ExpTypeSig{} <- parent, i == 0 = False | otherwise = True diff --git a/src/HSE/Generics.hs b/src/HSE/Generics.hs --- a/src/HSE/Generics.hs +++ b/src/HSE/Generics.hs @@ -3,5 +3,5 @@ module Data.Generics, module Data.Generics.PlateData ) where -import Data.Generics hiding (Infix) +import Data.Generics hiding (Infix, Fixity) import Data.Generics.PlateData diff --git a/src/HSE/Match.hs b/src/HSE/Match.hs --- a/src/HSE/Match.hs +++ b/src/HSE/Match.hs @@ -2,12 +2,9 @@ module HSE.Match where -import HSE.Generics import Data.Char import Data.List -import Data.Maybe import Language.Haskell.Exts -import HSE.Bracket import HSE.Util @@ -49,7 +46,10 @@ isCon (x:_) = isUpper x || x == ':' +isCon _ = False + isSym (x:_) = not $ isAlpha x || x `elem` "_'" +isSym _ = False instance Named Exp where @@ -90,6 +90,12 @@ toNamed x | isCon x = PApp (toNamed x) [] | otherwise = PVar $ toNamed x + + +instance Named TyVarBind where + fromNamed (KindedVar x _) = fromNamed x + fromNamed (UnkindedVar x) = fromNamed x + toNamed = UnkindedVar . toNamed instance Named Decl where diff --git a/src/HSE/NameMatch.hs b/src/HSE/NameMatch.hs new file mode 100644 --- /dev/null +++ b/src/HSE/NameMatch.hs @@ -0,0 +1,53 @@ + +module HSE.NameMatch(NameMatch, nameMatch) where + +import Language.Haskell.Exts +import qualified Data.Map as Map +import Control.Arrow +import Data.List +import Data.Function + + +type NameMatch = QName -> QName -> Bool + + +-- Given a list of import statements, are the names equal +-- The import statements are only in scope on the second name +-- +-- If the left is unqualified, then the right is dequalified and checked for match +-- If the left is qualified, then the right is wrapped and name resolved +nameMatch :: [ImportDecl] -> NameMatch +nameMatch imps = f + where + -- deal with "as" imports + resolve :: ModuleName -> ModuleName + resolve = \x -> Map.findWithDefault x x mp + where mp = Map.fromList [(as, importModule i) | i <- imps, Just as <- [importAs i]] + + -- return True if x is potentially imported by B + importedFrom :: ModuleName -> Name -> Bool + importedFrom = \modu x -> any (g x) $ Map.findWithDefault [(True,[]) | modu == ModuleName "Prelude"] modu mp + where mp = Map.fromList $ map (fst . head &&& map snd) $ + groupBy ((==) `on` fst) $ sortBy (compare `on` fst) + [(importModule i, importSpecNames i) | i <- imps, not $ importQualified i] + + g x (hide,y) = hide /= (x `elem` y) + + + f (Qual xm x) (Qual ym y) = x == y && xm == resolve ym + f (Qual xm x) (UnQual y) = x == y && importedFrom xm x + f x y = x == y + + +importSpecNames :: ImportDecl -> (Bool, [Name]) +importSpecNames x = case importSpecs x of + Nothing -> (True, []) + Just (b, x) -> (b, concatMap f x) + where + f (IVar x) = [x] + f (IAbs x) = [x] + f (IThingAll x) = [x] + f (IThingWith x ys) = x : map g ys + g (VarName x) = x + g (ConName x) = x + diff --git a/src/HSE/Operators.hs b/src/HSE/Operators.hs --- a/src/HSE/Operators.hs +++ b/src/HSE/Operators.hs @@ -11,7 +11,9 @@ import Data.Char import Data.List import Data.Maybe -import Language.Haskell.Exts +import Language.Haskell.Exts hiding + (preludeFixities, baseFixities, applyFixities, Fixity, + infixr_, infixl_, infix_) import HSE.Match import HSE.Util import HSE.Bracket @@ -96,7 +98,7 @@ ] where f lhs rhs = g lhs == g rhs || error ("Fixity mismatch " ++ lhs ++ " =/= " ++ rhs) - g = transformBi (const nullSrcLoc) $ transformBi fromParen . applyFixities preludeFixities . fromParseOk . parseFileContents . (++) "foo = " + g = transformBi (const nullSrcLoc) $ transformBi fromParen . applyFixities preludeFixities . fromParseResult . parseFileContents . (++) "foo = " askFixity :: [FixityDecl] -> QOp -> (Assoc, Int) diff --git a/src/HSE/Util.hs b/src/HSE/Util.hs --- a/src/HSE/Util.hs +++ b/src/HSE/Util.hs @@ -27,9 +27,6 @@ moduleImports :: Module -> [ImportDecl] moduleImports (Module _ _ _ _ _ x _) = x -fromParseOk :: ParseResult a -> a -fromParseOk (ParseOk x) = x - isChar :: Exp -> Bool isChar (Lit (Char _)) = True isChar _ = False @@ -56,8 +53,6 @@ isInfixApp InfixApp{} = True; isInfixApp _ = False isAnyApp x = isApp x || isInfixApp x isParen Paren{} = True; isParen _ = False -isListComp ListComp{} = True; isListComp _ = False -isIf If{} = True; isIf _ = False --------------------------------------------------------------------- diff --git a/src/Hint/All.hs b/src/Hint/All.hs --- a/src/Hint/All.hs +++ b/src/Hint/All.hs @@ -1,8 +1,6 @@ module Hint.All where -import Control.Monad -import HSE.All import Type import Hint.Match diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs --- a/src/Hint/Bracket.hs +++ b/src/Hint/Bracket.hs @@ -7,12 +7,14 @@ yes = (f x) ||| y where res = f x ||| y yes = if (f x) then y else z where res = if f x then y else z yes = if x then (f y) else z where res = if x then f y else z +yes = (a foo) :: Int where res = a foo :: Int no = groupFsts . sortFst $ mr yes = split "to" $ names where res = split "to" names yes = white $ keysymbol where res = white keysymbol yes = operator foo $ operator where res = operator foo operator no = operator foo $ operator bar +yes = (b $ c d) ++ e where res = b (c d) ++ e -} @@ -20,13 +22,12 @@ module Hint.Bracket where import Control.Arrow -import Data.Maybe import Type import HSE.All bracketHint :: Hint -bracketHint = concatMap bracketExp . children0Exp nullSrcLoc +bracketHint _ = concatMap bracketExp . children0Exp nullSrcLoc bracketExp :: (SrcLoc,Exp) -> [Idea] bracketExp (loc,x) = @@ -39,4 +40,8 @@ testDollar loc x = [idea Error "Redundant $" loc x y | InfixApp a d b <- [x], opExp d ~= "$" - ,let y = App a b, not $ needBracket 0 y a, not $ needBracket 1 y b] + ,let y = App a b, not $ needBracket 0 y a, not $ needBracket 1 y b] ++ + [idea Error "Redundant $" loc x y | InfixApp a op b <- [x] + ,(first,Paren (InfixApp c1 d c2)) <- [(True,a),(False,b)], opExp d ~= "$" + ,let c = App c1 (Paren c2),let (a2,b2) = if first then (c,b) else (a,c) + ,let y = InfixApp a2 op b2] diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs --- a/src/Hint/Lambda.hs +++ b/src/Hint/Lambda.hs @@ -24,6 +24,8 @@ yes = 0 where f x y = g x == g y ; res = "f = (==) `on` g" a + b = foo a b where res = "(+) = foo" type Yes a = Foo Char a +yes = foo (\x -> sum x) where res = sum +yes = foo (\x l -> sum x x l) where res = \x -> sum x x -} @@ -39,8 +41,8 @@ lambdaHint :: Hint -lambdaHint x@TypeDecl{} = lambdaType x -lambdaHint x = concatMap lambdaExp (universeBi x) ++ concatMap lambdaDecl (universe x) +lambdaHint _ x@TypeDecl{} = lambdaType x +lambdaHint _ x = concatMap lambdaExp (universeBi x) ++ concatMap lambdaDecl (universe x) lambdaExp :: Exp -> [Idea] @@ -51,6 +53,9 @@ f PWildCard = Just $ Ident "_" f _ = Nothing res = App (toNamed "const") y +lambdaExp o@(Lambda loc vs x) | length vs /= length vs2 = + [warn "Eta reduce" loc o $ if null vs2 then x2 else Lambda loc vs2 x2] + where (vs2,x2) = etaReduces vs x lambdaExp _ = [] @@ -109,6 +114,6 @@ t2 = TypeDecl src name (take (length args - i) args) t -- return the number you managed to delete - f :: [Name] -> Type -> (Int, Type) - f (x:xs) (TyApp t1 (TyVar v)) | v == x = first (+1) $ f xs t1 + f :: [TyVarBind] -> Type -> (Int, Type) + f (x:xs) (TyApp t1 (TyVar v)) | fromNamed v == fromNamed x = first (+1) $ f xs t1 f _ t = (0,t) diff --git a/src/Hint/List.hs b/src/Hint/List.hs --- a/src/Hint/List.hs +++ b/src/Hint/List.hs @@ -28,7 +28,7 @@ listHint :: Hint -listHint = listDecl +listHint _ = listDecl listDecl :: Decl -> [Idea] listDecl x = concatMap (listExp False) (children0Exp nullSrcLoc x) ++ diff --git a/src/Hint/ListRec.hs b/src/Hint/ListRec.hs --- a/src/Hint/ListRec.hs +++ b/src/Hint/ListRec.hs @@ -35,8 +35,8 @@ import Data.Generics.PlateData -listRecHint :: Decl -> [Idea] -listRecHint = concatMap f . universe +listRecHint :: Hint +listRecHint _ = concatMap f . universe where f o = maybeToList $ do let x = o @@ -171,7 +171,7 @@ -- a list of application, with any necessary brackets appsBracket :: [Exp] -> Exp -appsBracket = foldl1 (\x y -> ensureBracket1 $ App x y) +appsBracket = foldl1 (\x -> ensureBracket1 . App x) -- generate a lambda, but prettier (if possible) diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -10,7 +10,6 @@ module Hint.Match(readMatch) where import Data.Char -import Data.Generics.PlateData import Data.List import Data.Maybe import Type @@ -27,39 +26,40 @@ readMatch = findIdeas . filter isMatchExp -findIdeas :: [Setting] -> Decl -> [Idea] -findIdeas matches decl = +findIdeas :: [Setting] -> NameMatch -> Decl -> [Idea] +findIdeas matches nm decl = [ idea (rank m) (hint m) loc x y | (loc, x) <- universeExp nullSrcLoc decl, not $ isParen x - , m <- matches, Just y <- [matchIdea m x]] + , m <- matches, Just y <- [matchIdea nm m x]] -matchIdea :: Setting -> Exp -> Maybe Exp -matchIdea MatchExp{lhs=lhs,rhs=rhs,side=side} x = do - u <- unify lhs x +matchIdea :: NameMatch -> Setting -> Exp -> Maybe Exp +matchIdea nm MatchExp{lhs=lhs,rhs=rhs,side=side} x = do + u <- unify nm lhs x u <- check u guard $ checkSide side u return $ dotContract $ performEval $ subst u rhs -- unify a b = c, a[c] = b -unify :: Exp -> Exp -> Maybe [(String,Exp)] -unify (Do xs) (Do ys) | length xs == length ys = concatZipWithM unifyStmt xs ys -unify (Lambda _ xs x) (Lambda _ ys y) | length xs == length ys = liftM2 (++) (unify x y) (concatZipWithM unifyPat xs ys) -unify x y | isParen x || isParen y = unify (fromParen x) (fromParen y) -unify (Var (fromNamed -> v)) y | isUnifyVar v = Just [(v,y)] -unify x y | ((==) `on` descend (const $ toNamed "_")) x y = concatZipWithM unify (children x) (children y) -unify x o@(view -> App2 op y1 y2) - | op ~= "$" = unify x $ y1 `App` y2 - | op ~= "." = unify x $ dotExpand o -unify x (InfixApp lhs op rhs) = unify x (opExp op `App` lhs `App` rhs) -unify _ _ = Nothing +unify :: NameMatch -> Exp -> Exp -> Maybe [(String,Exp)] +unify nm (Do xs) (Do ys) | length xs == length ys = concatZipWithM (unifyStmt nm) xs ys +unify nm (Lambda _ xs x) (Lambda _ ys y) | length xs == length ys = liftM2 (++) (unify nm x y) (concatZipWithM unifyPat xs ys) +unify nm x y | isParen x || isParen y = unify nm (fromParen x) (fromParen y) +unify nm (Var (fromNamed -> v)) y | isUnifyVar v = Just [(v,y)] +unify nm (Var x) (Var y) | nm x y = Just [] +unify nm x y | ((==) `on` descend (const $ toNamed "_")) x y = concatZipWithM (unify nm) (children x) (children y) +unify nm x o@(view -> App2 op y1 y2) + | op ~= "$" = unify nm x $ y1 `App` y2 + | op ~= "." = unify nm x $ dotExpand o +unify nm x (InfixApp lhs op rhs) = unify nm x (opExp op `App` lhs `App` rhs) +unify nm _ _ = Nothing -unifyStmt :: Stmt -> Stmt -> Maybe [(String,Exp)] -unifyStmt (Generator _ p1 x1) (Generator _ p2 x2) = liftM2 (++) (unifyPat p1 p2) (unify x1 x2) -unifyStmt x y | ((==) `on` descendBi (const (toNamed "_" :: Exp))) x y = concatZipWithM unify (childrenBi x) (childrenBi y) -unifyStmt _ _ = Nothing +unifyStmt :: NameMatch -> Stmt -> Stmt -> Maybe [(String,Exp)] +unifyStmt nm (Generator _ p1 x1) (Generator _ p2 x2) = liftM2 (++) (unifyPat p1 p2) (unify nm x1 x2) +unifyStmt nm x y | ((==) `on` descendBi (const (toNamed "_" :: Exp))) x y = concatZipWithM (unify nm) (childrenBi x) (childrenBi y) +unifyStmt nm _ _ = Nothing unifyPat :: Pat -> Pat -> Maybe [(String,Exp)] diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -16,6 +16,7 @@ no = do bar; a <- foo; return b yes = do x <- bar; x where res = do join bar no = do x <- bar; x; x +no = mdo hook <- mkTrigger pat (act >> rmHook hook) ; return hook -} @@ -33,7 +34,7 @@ monadHint :: Hint -monadHint = concatMap monadExp . universeExp nullSrcLoc +monadHint _ = concatMap monadExp . universeExp nullSrcLoc monadExp :: (SrcLoc,Exp) -> [Idea] monadExp (loc,x) = case x of @@ -42,7 +43,6 @@ [idea Error "Use join" loc x (Do y) | Just y <- [monadJoin xs]] ++ [idea Error "Redundant do" loc x y | [Qualifier y] <- [xs]] ++ concat [f x | Qualifier x <- init xs] - MDo xs -> monadExp (loc, Do xs) _ -> [] where f x = [idea Error ("Use " ++ name) loc x y diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs --- a/src/Hint/Naming.hs +++ b/src/Hint/Naming.hs @@ -31,7 +31,7 @@ namingHint :: Hint -namingHint x = [warn "Use camelCase" (declSrcLoc x) x2 (replaceNames res x2) | not $ null res] +namingHint _ x = [warn "Use camelCase" (declSrcLoc x) x2 (replaceNames res x2) | not $ null res] where res = [(n,y) | n <- nub $ getNames x, Just y <- [suggestName n]] x2 = shorten x @@ -60,9 +60,9 @@ _ -> [] where name = [fromNamed x] - names = map fromNamed (universeBi x :: [Name]) f (ConDecl x _) = [x] + f (InfixConDecl _ x _) = [x] f (RecDecl x ys) = x : concatMap fst ys diff --git a/src/Hint/Structure.hs b/src/Hint/Structure.hs --- a/src/Hint/Structure.hs +++ b/src/Hint/Structure.hs @@ -6,6 +6,8 @@