diff --git a/data/Default.hs b/data/Default.hs
--- a/data/Default.hs
+++ b/data/Default.hs
@@ -62,11 +62,21 @@
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
+warn = foldl f z (map g x) ==> foldl (f . g) z x
+warn = foldl' f z (map g x) ==> foldl' (f . g) z x
+warn = foldl1 f (map g x) ==> foldl1 (f . g) x
+warn = foldl1' f (map g x) ==> foldl1' (f . g) x
+warn = foldr1' f (map g x) ==> foldr1' (f . g) x
+warn = foldr1 f (map g x) ==> foldr1 (f . g) x
+
-- FOLDS
error = foldr (&&) True ==> and
-error = foldr (>>) (return ()) ==> sequence_
+error = foldl (&&) True ==> and
error = foldr (||) False ==> or
+error = foldl (||) False ==> or
+error = foldr (>>) (return ()) ==> sequence_
error = foldl (+) 0 ==> sum
warn = foldl (*) 1 ==> product
@@ -252,6 +262,7 @@
no = flip f x $ \y -> y*y+y
no = \x -> f x (g x)
yes = \x -> f x (g y) -- flip f (g y)
+no = foo (\ v -> f v . g)
import Prelude \
yes = flip mapM -- Control.Monad.forM
diff --git a/data/HLint.hs b/data/HLint.hs
--- a/data/HLint.hs
+++ b/data/HLint.hs
@@ -2,3 +2,13 @@
module HLint.HLint where
import HLint.Default
+import HLint.Builtin.List
+import HLint.Builtin.ListRec
+import HLint.Builtin.Monad
+import HLint.Builtin.Lambda
+import HLint.Builtin.Bracket
+import HLint.Builtin.Naming
+import HLint.Builtin.Structure
+import HLint.Builtin.Import
+import HLint.Builtin.Pragma
+import HLint.Builtin.Extensions
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.6.12
+version: 1.6.13
-- license is GPL v2 only
license: GPL
license-file: LICENSE
diff --git a/src/CmdLine.hs b/src/CmdLine.hs
--- a/src/CmdLine.hs
+++ b/src/CmdLine.hs
@@ -35,6 +35,7 @@
| Color
| Define String
| Include String
+ | Ext String
deriving Eq
@@ -45,6 +46,7 @@
,Option "c" ["color","colour"] (NoArg Color) "Color the output (requires ANSI terminal)"
,Option "i" ["ignore"] (ReqArg Skip "message") "Ignore a particular hint"
,Option "s" ["show"] (NoArg ShowAll) "Show all ignored ideas"
+ ,Option "e" ["extension"] (ReqArg Ext "ext") "File extensions to search (defaults to hs and lhs)"
,Option "t" ["test"] (NoArg Test) "Run in test mode"
,Option "" ["cpp-define"] (ReqArg Define "name[=value]") "CPP #define"
,Option "" ["cpp-include"] (ReqArg Include "dir") "CPP include path"
@@ -68,7 +70,8 @@
putStr helpText
exitWith ExitSuccess
- files <- concatMapM getFile files
+ let exts = [x | Ext x <- opt]
+ files <- concatMapM (getFile $ if null exts then ["hs","lhs"] else exts) files
let hintFiles = [x | Hints x <- opt]
hints <- mapM getHintFile $ hintFiles ++ ["HLint" | null hintFiles]
@@ -106,12 +109,12 @@
]
-getFile :: FilePath -> IO [FilePath]
-getFile file = do
+getFile :: [String] -> FilePath -> IO [FilePath]
+getFile exts file = do
b <- doesDirectoryExist file
if b then do
xs <- getDirectoryContentsRecursive file
- return [x | x <- xs, takeExtension x `elem` [".hs",".lhs"]]
+ return [x | x <- xs, drop 1 (takeExtension x) `elem` exts]
else do
b <- doesFileExist file
unless b $ error $ "Couldn't find file: " ++ file
diff --git a/src/HSE/Bracket.hs b/src/HSE/Bracket.hs
--- a/src/HSE/Bracket.hs
+++ b/src/HSE/Bracket.hs
@@ -40,6 +40,7 @@
| isAtom child = False
| InfixApp{} <- parent, isApp child = False
| ListComp{} <- parent = False
+ | List{} <- parent = False
| If{} <- parent, isAnyApp child = False
| App{} <- parent, i == 0, isApp child = False
| ExpTypeSig{} <- parent, i == 0 = False
diff --git a/src/HSE/Util.hs b/src/HSE/Util.hs
--- a/src/HSE/Util.hs
+++ b/src/HSE/Util.hs
@@ -57,6 +57,7 @@
isInfixApp InfixApp{} = True; isInfixApp _ = False
isAnyApp x = isApp x || isInfixApp x
isParen Paren{} = True; isParen _ = False
+isLambda Lambda{} = True; isLambda _ = False
isMDo MDo{} = True; isMDo _ = False
isBoxed Boxed{} = True; isBoxed _ = False
isDerivDecl DerivDecl{} = True; isDerivDecl _ = False
@@ -69,6 +70,13 @@
isParComp ParComp{} = True; isParComp _ = False
isPatTypeSig PatTypeSig{} = True; isPatTypeSig _ = False
isQuasiQuote QuasiQuote{} = True; isQuasiQuote _ = False
+
+
+-- which names are bound by a declaration
+declBind :: Decl -> [Name]
+declBind (FunBind (Match _ x _ _ _ _ : _)) = [x]
+declBind (PatBind _ x _ _ _) = [x | PVar x <- universe x]
+declBind _ = []
---------------------------------------------------------------------
-- HSE FUNCTIONS
diff --git a/src/Hint/All.hs b/src/Hint/All.hs
--- a/src/Hint/All.hs
+++ b/src/Hint/All.hs
@@ -2,6 +2,8 @@
module Hint.All where
import Type
+import Data.List
+import Data.Maybe
import Hint.Match
import Hint.List
@@ -36,4 +38,6 @@
allHints :: [Setting] -> [Hint]
-allHints xs = dynamicHints xs : map snd staticHints
+allHints xs = dynamicHints xs : map f builtin
+ where builtin = nub [x | Builtin x <- xs]
+ f x = fromMaybe (error $ "Unknown builtin hints: HLint.Builtin." ++ x) $ lookup x staticHints
diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs
--- a/src/Hint/Bracket.hs
+++ b/src/Hint/Bracket.hs
@@ -2,6 +2,7 @@
yes = (f x) x -- f x x
no = f (x x)
+yes = (foo) -- foo
yes = (f x) ||| y -- f x ||| y
yes = if (f x) then y else z -- if f x then y else z
yes = if x then (f y) else z -- if x then f y else z
@@ -15,6 +16,7 @@
yes = (b $ c d) ++ e -- b (c d) ++ e
yes = (a b $ c d) ++ e -- a b (c d) ++ e
no = (f . g $ a) ++ e
+yes = [(foo bar)] -- [foo bar]
-}
@@ -27,7 +29,7 @@
bracketHint :: DeclHint
-bracketHint _ = concatMap bracketExp . children0Exp nullSrcLoc
+bracketHint _ _ = concatMap bracketExp . children0Exp nullSrcLoc
bracketExp :: (SrcLoc,Exp) -> [Idea]
bracketExp (loc,x) =
diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs
--- a/src/Hint/Lambda.hs
+++ b/src/Hint/Lambda.hs
@@ -51,8 +51,8 @@
lambdaHint :: DeclHint
-lambdaHint _ x@TypeDecl{} = lambdaType x
-lambdaHint _ x = concatMap (uncurry lambdaExp) (universeExp nullSrcLoc x) ++ concatMap lambdaDecl (universe x)
+lambdaHint _ _ x@TypeDecl{} = lambdaType x
+lambdaHint _ _ x = concatMap (uncurry lambdaExp) (universeExp nullSrcLoc x) ++ concatMap lambdaDecl (universe x)
lambdaExp :: SrcLoc -> Exp -> [Idea]
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 :: DeclHint
-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
@@ -36,7 +36,7 @@
listRecHint :: DeclHint
-listRecHint _ = concatMap f . universe
+listRecHint _ _ = concatMap f . universe
where
f o = maybeToList $ do
let x = o
diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs
--- a/src/Hint/Match.hs
+++ b/src/Hint/Match.hs
@@ -27,8 +27,8 @@
readMatch = findIdeas . filter isMatchExp
-findIdeas :: [Setting] -> NameMatch -> Decl -> [Idea]
-findIdeas matches nm decl =
+findIdeas :: [Setting] -> NameMatch -> Module -> Decl -> [Idea]
+findIdeas matches nm _ decl =
[ idea (rankS m) (hintS m) loc x y
| (loc, x) <- universeExp nullSrcLoc decl, not $ isParen x
, m <- matches, Just y <- [matchIdea nm m x]]
@@ -39,7 +39,9 @@
u <- unify nm lhs x
u <- check u
guard $ checkSide side u
- return $ unqualify nm $ dotContract $ performEval $ subst u rhs
+ let rhs2 = subst u rhs
+ guard $ checkDot lhs rhs2
+ return $ unqualify nm $ dotContract $ performEval rhs2
-- unify a b = c, a[c] = b
@@ -102,6 +104,12 @@
x2 <- lookup (fromNamed x) bind
y2 <- lookup (fromNamed y) bind
return $ x2 `notElem` universe y2
+
+
+-- If they have have a lambda in the pattern
+-- don't allow dot contraction to happen, as it's usually wrong
+checkDot :: Exp -> Exp -> Bool
+checkDot lhs rhs2 = not $ any isLambda (universeBi lhs) && toNamed "?" `elem` universe rhs2
-- perform a substitution
diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs
--- a/src/Hint/Monad.hs
+++ b/src/Hint/Monad.hs
@@ -42,7 +42,7 @@
monadHint :: DeclHint
-monadHint _ = concatMap monadExp . universeExp nullSrcLoc
+monadHint _ _ = concatMap monadExp . universeExp nullSrcLoc
monadExp :: (SrcLoc,Exp) -> [Idea]
monadExp (loc,x) = case x of
diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs
--- a/src/Hint/Naming.hs
+++ b/src/Hint/Naming.hs
@@ -5,7 +5,8 @@
_*[A-Za-z]*_?'?
Apply this to things that would get exported by default only
- Also disallow prop_ as it's a standard QuickCheck idiom
+ Also allow prop_ as it's a standard QuickCheck idiom
+ Also don't suggest anything mentioned elsewhere in the module
data Yes = Foo | Bar'Test -- data Yes = Foo | BarTest
@@ -16,22 +17,27 @@
yes_foo = yes_foo + yes_foo -- yesFoo = ...
no = 1 where yes_foo = 2
a -== b = 1
+myTest = 1; my_test = 1
-}
-module Hint.Naming where
+module Hint.Naming(namingHint) where
import HSE.All
import Type
import Data.List
import Data.Char
import Data.Maybe
+import qualified Data.Set as Set
namingHint :: DeclHint
-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]]
+namingHint _ modu = naming $ Set.fromList [x | Ident x <- universeBi modu]
+
+naming :: Set.Set String -> Decl -> [Idea]
+naming seen 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], not $ y `Set.member` seen]
x2 = shorten x
diff --git a/src/Hint/Structure.hs b/src/Hint/Structure.hs
--- a/src/Hint/Structure.hs
+++ b/src/Hint/Structure.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ViewPatterns, PatternGuards #-}
{-
Improve the structure of code
@@ -8,6 +8,13 @@
no x y = if a then b else c
yes x = case x of {True -> a ; False -> b} -- if x then a else b
yes x = case x of {False -> a ; _ -> b} -- if x then b else a
+foo b | c <- f b = c -- foo (f -> c) = c
+foo x y b z | c:cs <- f g b = c -- foo x y (f g -> c:cs) z = c
+foo b | c <- f b = c + b
+foo b | c <- f b = c where f = here
+foo b | c <- f b = c where foo = b
+foo b | c <- f b = c \
+ | c <- f b = c
-}
@@ -16,13 +23,14 @@
import HSE.All
import Type
+import Util
import Data.List
import Data.Maybe
structureHint :: DeclHint
-structureHint _ x = concat [concatMap useGuards xs | FunBind xs <- [x]] ++
- concatMap useIf (universeExp nullSrcLoc x)
+structureHint _ _ x = concat [concatMap useGuards xs | FunBind xs <- [x]] ++
+ concatMap useIf (universeExp nullSrcLoc x)
useGuards :: Match -> [Idea]
@@ -31,6 +39,19 @@
where
guards = asGuards bod
x2 = Match a b c d (GuardedRhss guards) e
+
+useGuards o@(Match sl b pats d (GuardedRhss [GuardedRhs _ [Generator _ pat (App op (Var (UnQual p)))] bod]) (BDecls decs))
+ | Just i <- findIndex (== PVar p) pats
+ , p `notElem` (vr bod ++ vr decs)
+ , vr op `disjoint` decsBind, pvr pats `disjoint` vr op, pvr pat `disjoint` pvr pats
+ = [warn "Use view patterns" sl o $
+ Match sl b (take i pats ++ [PParen $ PViewPat op pat] ++ drop (i+1) pats) d (UnGuardedRhs bod) (BDecls decs)]
+ where
+ decsBind = nub $ concatMap declBind decs
+
+ vr x = [y | Var (UnQual y) <- universeBi x]
+ pvr x = [y | PVar y <- universeBi x]
+
useGuards _ = []
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,3 +1,21 @@
+{-
+HLint, Haskell source code suggestions
+Copyright (C) 2006-2009, Neil Mitchell
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; version 2 of the License.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+-}
+
{-# LANGUAGE RecordWildCards #-}
module Main where
diff --git a/src/Settings.hs b/src/Settings.hs
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE PatternGuards, ViewPatterns #-}
-module Settings where
+module Settings(readSettings, classify) where
import HSE.All
import Paths_hlint
@@ -16,20 +16,21 @@
-- Return the list of settings commands
readSettings :: [FilePath] -> IO [Setting]
readSettings xs = do
- mods <- concatMapM readHints xs
- return $ concatMap (concatMap readSetting . concatMap getEquations . moduleDecls) mods
+ (builtin,mods) <- fmap unzipEither $ concatMapM readHints xs
+ return $ map Builtin builtin ++ concatMap (concatMap readSetting . concatMap getEquations . moduleDecls) mods
-- read all the files
-- in future this should also do import chasing, but
-- currently it doesn't
-readHints :: FilePath -> IO [Module]
+readHints :: FilePath -> IO [Either String Module]
readHints file = do
y <- fromParseResult `fmap` parseFile parseFlags{implies=True} file
ys <- concatMapM (f . fromNamed . importModule) $ moduleImports y
- return $ y:ys
+ return $ Right y:ys
where
- f x | "HLint." `isPrefixOf` x = do
+ f x | "HLint.Builtin." `isPrefixOf` x = return [Left $ drop 14 x]
+ | "HLint." `isPrefixOf` x = do
dat <- getDataDir
readHints $ dat drop 6 x <.> "hs"
| otherwise = readHints $ x <.> "hs"
diff --git a/src/Type.hs b/src/Type.hs
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -30,6 +30,7 @@
data Setting
= Classify {rankS :: Rank, hintS :: String, funcS :: FuncName}
| MatchExp {rankS :: Rank, hintS :: String, lhs :: Exp, rhs :: Exp, side :: Maybe Exp}
+ | Builtin String -- use a builtin hint set
deriving Show
data Idea
@@ -76,8 +77,8 @@
---------------------------------------------------------------------
-- HINTS
-type DeclHint = NameMatch -> Decl -> [Idea]
-type ModuHint = NameMatch -> Module -> [Idea]
+type DeclHint = NameMatch -> Module -> Decl -> [Idea]
+type ModuHint = NameMatch -> Module -> [Idea]
data Hint = DeclHint {declHint :: DeclHint} | ModuHint {moduHint :: ModuHint}
@@ -101,4 +102,4 @@
nm = nameMatch $ moduleImports m
order n = map (\i -> i{func = (name,n)}) . sortBy (comparing loc)
in order "" [i | ModuHint h <- h, i <- h nm m] ++
- concat [order (fromNamed d) [i | DeclHint h <- h, i <- h nm d] | d <- moduleDecls m]
+ concat [order (fromNamed d) [i | DeclHint h <- h, i <- h nm m d] | d <- moduleDecls m]
diff --git a/src/Util.hs b/src/Util.hs
--- a/src/Util.hs
+++ b/src/Util.hs
@@ -46,9 +46,21 @@
isRight = not . isLeft
+unzipEither :: [Either a b] -> ([a], [b])
+unzipEither (x:xs) = case x of
+ Left y -> (y:a,b)
+ Right y -> (a,y:b)
+ where (a,b) = unzipEither xs
+unzipEither [] = ([], [])
+
+
listM' :: Monad m => [a] -> m [a]
listM' x = length x `seq` return x
groupSortFst :: Ord a => [(a,b)] -> [(a,[b])]
groupSortFst = map (fst . head &&& map snd) . groupBy ((==) `on` fst) . sortBy (comparing fst)
+
+
+disjoint :: Eq a => [a] -> [a] -> Bool
+disjoint xs = null . intersect xs