packages feed

hlint 1.4 → 1.6

raw patch · 27 files changed

+277/−137 lines, 27 filesdep +paralleldep ~haskell-src-extsdep ~hscolour

Dependencies added: parallel

Dependency ranges changed: haskell-src-exts, hscolour

Files

data/Default.hs view
@@ -57,6 +57,7 @@ warn  "Use null" = length x /= 0 ==> not (null x) error "Use :" = (\x -> [x]) ==> (:[]) error = map (uncurry f) (zip x y) ==> zipWith f x y+error = not (elem x y) ==> notElem x y  -- FOLDS @@ -107,7 +108,7 @@ error = sequence_ (map f x) ==> mapM_ f x warn  = flip mapM ==> forM warn  = flip mapM_ ==> forM_-error = when (not x) y ==> unless x y+error = when (not x) ==> unless x error = x >>= id ==> join x  -- MONAD LIST@@ -134,6 +135,7 @@ error = maybe x id  ==> fromMaybe x error = maybe False (const True) ==> isJust error = maybe True (const False) ==> isNothing+error = catMaybes (map f x) ==> mapMaybe f x  -- MATHS
data/report.html view
@@ -2,7 +2,7 @@ <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en"> <head> <meta http-equiv="Content-Type" content="application/xhtml+xml; charset=UTF-8" />-<title>HLint report</title>+<title>HLint Report</title> <script type='text/javascript'>  /* == Algorithm for show/unshow ==@@ -14,10 +14,11 @@  // CSS MANIPULATION // -function deleteRule()+function deleteRules(n) { 	var css = document.styleSheets[0];-	css.deleteRule(css.cssRules.length-1);+	for (var i = 0; i < n; i++)+		css.deleteRule(css.cssRules.length-1); }  function insertRule(s)@@ -33,23 +34,40 @@ function show(id) { 	if (id == last) return;--	for (var i = (last == "" ? 1 : 3); i > 0; i--)-		deleteRule();- 	if (id == "")+	{+		deleteRules(3); 		insertRule(".all {font-weight: bold;}");+	} 	else 	{-		insertRule("#content div {display:none}");-		insertRule("#content div." + id + " {display:block}");-		insertRule("#" + id + "{font-weight:bold}");+		if (last == "")+		{+			deleteRules(1);+			insertRule("#content div {display:none;}");+		}+		else+		{+			deleteRules(2);+		}+		insertRule("#content div." + id + " {display:block;}");+		insertRule("#" + id + "{font-weight:bold;}"); 	}+ 	last = id; }  </script> <style type="text/css">+/* These rules are manipulated by the script.+   The commented form is how it looks with an id selected */++.all {font-weight: bold;}      /* #content div {display:none;} */+                               /* #content div.id {display:block;} */+                               /* #id {font-weight: bold;} */++</style>+<style type="text/css"> /* See http://www.webreference.com/programming/css_frames/ */ body { 	margin:0;@@ -75,6 +93,7 @@ 	padding-left: 7px; 	padding-right: 7px; 	-moz-border-radius: 5px;+	-webkit-border-radius: 5px;  	display:none; /* Override if script present */ }@@ -111,13 +130,10 @@ .script #leftbar {display: block;}  /* From HsColour */-.keyglyph, .layout {color: red;}-.keyword {color: blue;}-.comment, .comment a {color: green;}-.str, .chr {color: teal;}--/* MUST BE THE LAST RULE SINCE MANIPULATED BY SCRIPT */-.all {font-weight: bold;}+.hs-keyglyph, .hs-layout {color: red;}+.hs-keyword {color: blue;}+.hs-comment, .hs-comment a {color: green;}+.hs-str, .hs-chr {color: teal;} </style> </head> <body>
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.6 build-type:         Simple name:               hlint-version:            1.4+version:            1.6 license:            GPL license-file:       LICENSE category:           Development@@ -27,10 +27,10 @@  executable hlint     build-depends:-        base == 4.*, syb, filepath, directory, mtl, containers, hscolour == 1.10.*,-        haskell-src-exts == 0.4.8.*, uniplate == 1.2.* && >= 1.2.0.2+        base == 4.*, syb, filepath, directory, mtl, containers, hscolour >= 1.10,+        haskell-src-exts == 1.0.0, uniplate == 1.2.* && >= 1.2.0.2, parallel -    ghc-options:        -fno-warn-overlapping-patterns+    ghc-options:        -fno-warn-overlapping-patterns -threaded      -- ViewPatterns not yet supported by Cabal as an extension     -- extensions:         ViewPatterns, PatternGuards, MultiParamTypeClasses@@ -51,6 +51,7 @@         HSE.Match         HSE.Operators         HSE.Util+        HSE.NameMatch         Hint.All         Hint.Bracket         Hint.Lambda
hlint.htm view
@@ -146,6 +146,12 @@ (add-hook 'haskell-mode-hook 'my-haskell-mode-hook) </pre> +<h3>Parallel Operation</h3>++<p>+	To run HLint on <i>n</i> processors append the flags <tt>+RTS -N<i>n</i></tt>, as described in the <a href="http://www.haskell.org/ghc/docs/latest/html/users_guide/runtime-control.html">GHC user manual</a>. HLint will usually perform fastest if <i>n</i> is equal to the number of physical processors.+</p>+ <h2>FAQ</h2>  <h3>Why are suggestions not applied recursively?</h3>@@ -200,7 +206,7 @@ 	<li><b>Generalise</b> - suggests replacing specific variants of functions (i.e. <tt>map</tt>) with more generic functions (i.e. <tt>fmap</tt>).</li> </ul> <p>-	As an example, to check the file <tt>Example.hs</tt> with both the default hints and the dollar hint, I could type: <tt>hlint Example.hs --hint Default --hint Dollar</tt>. Alternatively, I could create the file <tt>HLint.hs</tt> in the working directory and give it the contents:+	As an example, to check the file <tt>Example.hs</tt> with both the default hints and the dollar hint, I could type: <tt>hlint Example.hs --hint=Default --hint=Dollar</tt>. Alternatively, I could create the file <tt>HLint.hs</tt> in the working directory and give it the contents: </p> <pre> import HLint.Default@@ -216,7 +222,7 @@ error = concat (map f x) ==> concatMap f x </pre> <p>-	The line can be read as replace <tt>concat (map <i>f</i> <i>x</i>)</tt> with <tt>concat (map <i>f</i> <i>x</i>)</tt>. 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 <i>not</i> be given in point free style, as this reduces the power of the matching. Hints may start with <tt>error</tt> or <tt>warn</tt> to denote how severe they are by default.+	The line can be read as replace <tt>concat (map <i>f</i> <i>x</i>)</tt> with <tt>concatMap <i>f</i> <i>x</i></tt>. 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 <i>not</i> be given in point free style, as this reduces the power of the matching. Hints may start with <tt>error</tt> or <tt>warn</tt> to denote how severe they are by default. </p><p> 	If you come up with interesting hints, please submit them. For example, some of the hints about <tt>last</tt> were supplied by Henning Thielemann. </p>
src/CmdLine.hs view
@@ -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"     ]
src/HSE/All.hs view
@@ -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+    ]
src/HSE/Bracket.hs view
@@ -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
src/HSE/Generics.hs view
@@ -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
src/HSE/Match.hs view
@@ -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
+ src/HSE/NameMatch.hs view
@@ -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+
src/HSE/Operators.hs view
@@ -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)
src/HSE/Util.hs view
@@ -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   ---------------------------------------------------------------------
src/Hint/All.hs view
@@ -1,8 +1,6 @@  module Hint.All where -import Control.Monad-import HSE.All import Type  import Hint.Match
src/Hint/Bracket.hs view
@@ -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 </TEST> -} @@ -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]
src/Hint/Lambda.hs view
@@ -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 </TEST> -} @@ -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)
src/Hint/List.hs view
@@ -28,7 +28,7 @@   listHint :: Hint-listHint = listDecl+listHint _ = listDecl  listDecl :: Decl -> [Idea] listDecl x = concatMap (listExp False) (children0Exp nullSrcLoc x) ++
src/Hint/ListRec.hs view
@@ -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)
src/Hint/Match.hs view
@@ -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)]
src/Hint/Monad.hs view
@@ -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 </TEST> -} @@ -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
src/Hint/Naming.hs view
@@ -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
src/Hint/Structure.hs view
@@ -6,6 +6,8 @@ <TEST> yes x y = if a then b else if c then d else e where res = "yes x y\n  | a = b\n  | c = d\n  | otherwise = e" no x y = if a then b else c+yes x = case x of {True -> a ; False -> b} where res = "if x then a else b"+yes x = case x of {False -> a ; _ -> b} where res = "if x then b else a" </TEST> -} @@ -15,13 +17,12 @@ import HSE.All import Type import Data.List-import Data.Char import Data.Maybe   structureHint :: Hint-structureHint (FunBind xs) = concatMap useGuards xs-structureHint _ = []+structureHint _ x = concat [concatMap useGuards xs | FunBind xs <- [x]] +++                    concatMap useIf (universeExp nullSrcLoc x)   useGuards :: Match -> [Idea]@@ -37,3 +38,16 @@ asGuards (Paren x) = asGuards x asGuards (If a b c) = GuardedRhs nullSrcLoc [Qualifier a] b : asGuards c asGuards x = [GuardedRhs nullSrcLoc [Qualifier $ toNamed "otherwise"] x]+++useIf :: (SrcLoc,Exp) -> [Idea]+useIf (loc,x@(Case on [simpAlt -> Just (as,av), simpAlt -> Just (bs,bv)]))+    | as == "True"  && bs `elem` ["False","_"] = iff av bv+    | as == "False" && bs `elem` ["True" ,"_"] = iff bv av+    where+        iff t f = [warn "Use if" loc x (If on t f)]+useIf _ = []++simpAlt (Alt _ p (UnGuardedAlt x) (BDecls [])) = Just (prettyPrint p, x)+simpAlt _ = Nothing+
src/Main.hs view
@@ -6,8 +6,7 @@ import Control.Monad import Data.List import Data.Maybe-import System.Directory-import Data.Generics.PlateData+import System.Exit  import CmdLine import Settings@@ -15,9 +14,8 @@ import Type import Test import Util-import HSE.All+import Parallel import Hint.All-import Paths_hlint   main = do@@ -25,8 +23,9 @@     if cmdTest then test else do         settings <- readSettings cmdHintFiles         let extra = [Classify ("","") Ignore x | x <- cmdIgnore]-        let apply = map (classify $ settings ++ extra) . applyHint (allHints settings)-        ideas <- concatMapM (liftM apply . parseFile) cmdFiles+        let apply :: FilePath -> IO [Idea]+            apply = fmap (fmap $ classify $ settings ++ extra) . applyHint (allHints settings)+        ideas <- liftM concat $ parallel [listM' =<< apply x | x <- cmdFiles]         showItem <- if cmdColor then showANSI else return show         mapM_ putStrLn [showItem i | i <- ideas, cmdShowAll || rank i /= Ignore] @@ -34,9 +33,9 @@         let counts = map (head &&& length) $ group $ sort $ map rank ideas         let [ignore,warn,err] = map (fromMaybe 0 . flip lookup counts) [Ignore,Warning,Error]         let total = ignore + warn + err-        let shown = if cmdShowAll then total else total-ignore+        let shown = if cmdShowAll then total else total - ignore -        let ignored = [show i ++ " ignored" | let i = total-shown, i /= 0]+        let ignored = [show i ++ " ignored" | let i = total - shown, i /= 0]         let errors = [show err ++ " error" ++ ['s'|err/=1] | err /= 0]          if shown == 0 then do@@ -47,6 +46,9 @@                 putStrLn $ "Writing report to " ++ x ++ " ..."                 writeReport x ideas             printMsg ("Found " ++ show shown ++ " suggestion" ++ ['s'|shown/=1]) (errors++ignored)++        when (err > 0) $+            exitWith $ ExitFailure 1   printMsg :: String -> [String] -> IO ()
src/Report.hs view
@@ -4,7 +4,6 @@  import Type import Control.Arrow-import Language.Haskell.Exts import Data.List import Data.Maybe import Data.Version
src/Settings.hs view
@@ -7,7 +7,6 @@ import Type import Data.Char import Data.List-import System.Directory import System.FilePath import Util import Data.Generics.PlateData@@ -26,7 +25,7 @@ -- currently it doesn't readHints :: FilePath -> IO [Module] readHints file = do-    y <- parseFile file+    y <- fromParseResult `fmap` parseFile file     ys <- concatMapM (f . fromNamed . importModule) $ moduleImports y     return $ y:ys     where@@ -55,8 +54,8 @@ readSetting :: Decl -> [Setting] readSetting (FunBind [Match src (Ident (getRank -> rank)) pats _            (UnGuardedRhs bod) (BDecls bind)])-    | InfixApp lhs op rhs <- bod, opExp op ~= "==>", [name] <- names =-        [MatchExp rank name (fromParen lhs) (fromParen rhs) (readSide bind)]+    | InfixApp lhs op rhs <- bod, opExp op ~= "==>" =+        [MatchExp rank (head names) (fromParen lhs) (fromParen rhs) (readSide bind)]     | otherwise = [Classify func rank n | n <- names2, func <- readFuncs bod]     where         names = getNames pats bod@@ -89,7 +88,9 @@ getNames ps _ | ps /= [] && all isPString ps = map fromPString ps getNames [] (InfixApp lhs op rhs) | opExp op ~= "==>" = ["Use " ++ head names]     where-        names = filter (not . isUnifyVar) $ map f (childrenBi rhs) \\ map f (childrenBi lhs) +        lnames = map f $ childrenBi lhs+        rnames = map f $ childrenBi rhs+        names = filter (not . isUnifyVar) $ (rnames \\ lnames) ++ rnames         f (Ident x) = x         f (Symbol x) = x getNames [] _ = [""]
src/Test.hs view
@@ -10,11 +10,8 @@ import Data.Either import System.Directory import System.FilePath-import Data.Generics.PlateData -import CmdLine import Settings-import Report import Type import Util import HSE.All@@ -57,27 +54,29 @@     putStr $ unlines failures     return (length failures, length tests)     where-        f (Test loc inp out) =+        f (nm, Test loc inp out) =                 ["Test failed " ++ showSrcLoc loc ++ " " ++                  concatMap ((++) " | " . show) ideas ++ "\n" ++                  prettyPrint inp | not good]             where-                ideas = hint inp+                ideas = hint nm inp                 good = case out of                     Nothing -> ideas == []                     Just x -> length ideas == 1 && (null x || to (head ideas) == x)  -parseTestFile :: FilePath -> IO [Test]+parseTestFile :: FilePath -> IO [(NameMatch, Test)] parseTestFile file = do     src <- readFile file-    src <- return $ unlines $ f $ lines src-    return $ map createTest $ concatMap getEquations . moduleDecls $ parseString file src+    return [(nm, createTest eqn)+           | code <- f $ lines src, let modu = fromParseResult $ parseString file code+           , let nm = nameMatch $ moduleImports modu+           , eqn <- concatMap getEquations $ moduleDecls modu]     where         open = isPrefixOf "<TEST>"         shut = isPrefixOf "</TEST>"         f [] = []-        f xs = inner ++ f (drop 1 test)+        f xs = unlines inner : f (drop 1 test)             where (inner,test) = break shut $ drop 1 $ dropWhile (not . open) xs
src/Type.hs view
@@ -78,14 +78,24 @@ --------------------------------------------------------------------- -- HINTS -type Hint = Decl -> [Idea]+type Hint = NameMatch -> Decl -> [Idea]   concatHints :: [Hint] -> Hint-concatHints hs x = concatMap ($x) hs+concatHints hs nm x = concatMap (\h -> h nm x) hs  -applyHint :: Hint -> Module -> [Idea]-applyHint h m = [i{func = (name,fromNamed d)}-                | d <- moduleDecls m, i <- sortBy (comparing loc) $ h d]-    where name = moduleName m+applyHint :: Hint -> FilePath -> IO [Idea]+applyHint h file = do+    src <- readFile file+    case parseString file src of+        ParseFailed sl msg -> do+            let ticks = ["  ","  ","> ","  ","  "]+            let bad = zipWith (++) ticks $ take 5 $ drop (srcLine sl - 3) $ lines src+            let bad2 = reverse $ dropWhile (all isSpace) $ reverse $ dropWhile (all isSpace) bad+            return [Idea ("","") Warning "Parse error" sl msg (unlines bad2)]+        ParseOk m -> do+            let name = moduleName m+            let nm = nameMatch $ moduleImports m+            return [ i{func = (name,fromNamed d)}+                   | d <- moduleDecls m, i <- sortBy (comparing loc) $ h nm d]
src/Util.hs view
@@ -41,3 +41,7 @@  isLeft Left{} = True; isLeft _ = False isRight = not . isLeft+++listM' :: Monad m => [a] -> m [a]+listM' x = length x `seq` return x