packages feed

hlint 1.7.3 → 1.8

raw patch · 20 files changed

+445/−165 lines, 20 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

data/Default.hs view
@@ -1,6 +1,21 @@  module HLint.Default where +import Control.Arrow+import Control.Monad+import Data.Function+import Data.Int+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Ord+import System.IO++import IO as System.IO+import List as Data.List+import Maybe as Data.Maybe+import Monad as Control.Monad+ -- I/O  error = putStrLn (show x) ==> print x@@ -111,6 +126,7 @@  error = id *** g ==> second g error = f *** id ==> first f+error = zip (map f x) (map g x) ==> map (f Control.Arrow.&&& g) x warn  = (\(x,y) -> (f x, g y)) ==> f Control.Arrow.*** g where _ = notIn [x,y] [f,g] warn  = (\x -> (f x, g x)) ==> f Control.Arrow.&&& g where _ = notIn x [f,g] warn  = (\(x,y) -> (f x,y)) ==> Control.Arrow.first f where _ = notIn [x,y] f@@ -231,7 +247,6 @@ error "Evaluate" = x - 0 ==> x error "Evaluate" = x * 1 ==> x error "Evaluate" = x / 1 ==> x-error "Evaluate" = id x ==> x error "Evaluate" = concat [a] ==> a error "Evaluate" = concat [] ==> [] @@ -305,6 +320,7 @@ yes = if p then s else return () -- Control.Monad.when p $ s error = a $$$$ b $$$$ c ==> a . b $$$$$ c yes = when (not . null $ asdf) -- unless (null asdf)+yes = id 1 -- 1   import Prelude \@@ -317,5 +333,19 @@ yes = flip mapM -- Control.Monad.forM import qualified Control.Monad \ yes = flip mapM -- Control.Monad.forM+import qualified Control.Monad as CM \+yes = flip mapM -- CM.forM+import qualified Control.Monad as CM(forM,filterM) \+yes = flip mapM -- CM.forM+import Control.Monad as CM(forM,filterM) \+yes = flip mapM -- forM+import Control.Monad hiding (forM) \+yes = flip mapM -- Control.Monad.forM+import Control.Monad hiding (filterM) \+yes = flip mapM -- forM+import qualified Data.Text.Lazy as DTL \+main = DTL.concat $ map (`DTL.snoc` '-') [DTL.pack "one", DTL.pack "two", DTL.pack "three"]+import Text.Blaze.Html5.Attributes as A \+main = A.id (stringValue id') </TEST> -}
data/Generalise.hs view
@@ -1,6 +1,9 @@  module HLint.Generalise where +import Data.Monoid+import Control.Monad+ warn = concatMap ==> (=<<) warn = liftM ==> fmap warn = map ==> fmap
data/HLint.hs view
@@ -1,5 +1,5 @@  module HLint.HLint where -import HLint.Default-import HLint.Builtin.All+import "hint" HLint.Default+import "hint" HLint.Builtin.All
data/Test.hs view
@@ -1,9 +1,11 @@ -- These hints are for test purposes, and are not intended to -- be used for real. +-- FIXME: Should make this module modules in one file, so can easily test lots of+--        things without them overlapping module HLint.Test where -import HLint.Builtin.Naming+import "hint" HLint.Builtin.Naming   error = Prelude.readFile ==> bad@@ -34,7 +36,10 @@ infix 9 + error = a * (b+c) ==> undefined +error = Array.head ==> head+error = tail ==> Array.tail + {- <TEST> main = readFile "foo" >>= putStr            \@@ -66,7 +71,18 @@ concatMop f x = concat (map f x) -- Data.List.concatMap f x  yes = 1 * 2+3 -- undefined-</TEST>--} +import Foo; test = Foo.id 1 +test = head+import Array; test = Array.head -- head+test = Array.head -- head+test = head+import qualified Array; test = head+import Array(tail); test = head+import Array(head); test = head -- head+import Array as A; test = A.head -- head+test = tail -- Array.tail+import qualified Array as B; test = tail -- B.tail+</TEST>+-}
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.6 build-type:         Simple name:               hlint-version:            1.7.3+version:            1.8 -- license is GPL v2 only license:            GPL license-file:       LICENSE
hlint.htm view
@@ -243,8 +243,8 @@ 	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-import HLint.Dollar+import "hint" HLint.Default+import "hint" HLint.Dollar </pre>  <h3>Ignoring hints</h3>
src/Apply.hs view
@@ -22,7 +22,7 @@ applyHintStr flags s file src = do     res <- parseString flags{infixes=[x | Infix x <- s]} file src     case snd res of-        ParseFailed sl msg -> map (classify s) `fmap` parseFailed flags sl msg src+        ParseFailed sl msg | length src `seq` True -> map (classify s) `fmap` parseFailed flags sl msg src         ParseOk m -> return $             let settings = mapMaybe readPragma $ moduleDecls m             in map (classify $ s ++ settings) $ parseOk (allHints s) m@@ -51,7 +51,7 @@         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+        nm = moduleScope m   allHints :: [Setting] -> [Hint]
src/CmdLine.hs view
@@ -17,10 +17,12 @@ import Data.Version  +-- FIXME: Hints vs GivenHints is horrible data Cmd = Cmd     {cmdTest :: Bool                 -- ^ run in test mode?     ,cmdFiles :: [FilePath]          -- ^ which files to run it on     ,cmdHintFiles :: [FilePath]      -- ^ which settingsfiles to use+    ,cmdGivenHints :: [FilePath]     -- ^ which settignsfiles were explicitly given     ,cmdReports :: [FilePath]        -- ^ where to generate reports     ,cmdIgnore :: [String]           -- ^ the hints to ignore     ,cmdShowAll :: Bool              -- ^ display all skipped items@@ -97,6 +99,7 @@      let hintFiles = [x | Hints x <- opt]     hints <- mapM (getHintFile dataDir) $ hintFiles ++ ["HLint" | null hintFiles]+    let givenHints = if null hintFiles then [] else hints      let cpphs = defaultCpphsOptions             {boolopts=defaultBoolOptions{hashline=False}@@ -113,6 +116,7 @@         {cmdTest = test         ,cmdFiles = files         ,cmdHintFiles = hints+        ,cmdGivenHints = givenHints         ,cmdReports = [x | Report x <- opt]         ,cmdIgnore = [x | Skip x <- opt]         ,cmdShowAll = ShowAll `elem` opt
src/HLint.hs view
@@ -42,7 +42,7 @@     cmd@Cmd{..} <- getCmd args     let flags = parseFlags{cpphs=cmdCpphs, encoding=cmdEncoding, language=cmdLanguage}     if cmdTest then-        test cmdDataDir >> return []+        test (\x -> hlint x >> return ()) cmdDataDir cmdGivenHints >> return []      else if null cmdFiles && notNull cmdFindHints then         mapM_ (\x -> putStrLn . fst =<< findSettings flags x) cmdFindHints >> return []      else if null cmdFiles then
src/HSE/NameMatch.hs view
@@ -1,54 +1,101 @@ -module HSE.NameMatch(NameMatch, nameMatch) where+module HSE.NameMatch(+    Scope, emptyScope, moduleScope, scopeImports,+    NameMatch, nameMatch, nameQualify+    ) where  import HSE.Type import HSE.Util-import HSE.Match-import qualified Data.Map as Map-import Util+import Data.List+import Data.Maybe +{-+the hint file can do: +import Prelude (filter)+import Data.List (filter)+import List (filter)++then filter on it's own will get expanded to all of them++import Data.List+import List as Data.List+++if Data.List.head x ==> x, then that might match List too+-}+ type NameMatch = QName S -> QName S -> 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 S] -> NameMatch-nameMatch imps = f+data Scope = Scope [ImportDecl S]+             deriving Show++moduleScope :: Module S -> Scope+moduleScope xs = Scope $ [prelude | not $ any isPrelude res] ++ res     where-        -- deal with "as" imports-        resolve :: ModuleName S -> ModuleName S-        resolve = \x -> Map.findWithDefault x (fromNamed x) mp-            where mp = Map.fromList [(fromNamed as, importModule i) | i <- imps, Just as <- [importAs i]]-        -        -- return True if x is potentially imported by B-        importedFrom :: ModuleName S -> Name S -> Bool-        importedFrom = \modu x ->-                any (g x) $ Map.findWithDefault [(True,[]) | fromNamed modu == "Prelude"] (fromNamed modu) mp-            where mp = Map.fromList $ groupSortFst-                       [(fromNamed $ importModule i, importSpecNames i) | i <- imps, not $ importQualified i]+        res = [x | x <- moduleImports xs, importPkg x /= Just "hint"]+        prelude = ImportDecl an (ModuleName an "Prelude") False False Nothing Nothing Nothing+        isPrelude x = fromModuleName (importModule x) == "Prelude" -                  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 (UnQual _ x) (Qual _ ym y) = x =~= y-        f x y = x =~= y+emptyScope :: Scope+emptyScope = Scope []  -importSpecNames :: ImportDecl S -> (Bool, [Name S])-importSpecNames x = case importSpecs x of-    Nothing -> (True, [])-    Just (ImportSpecList _ b x) -> (b, concatMap f x)+scopeImports :: Scope -> [ImportDecl S]+scopeImports (Scope x) = x++++-- given A B x y, does A{x} possibly refer to the same name as B{y}+-- this property is reflexive+nameMatch :: Scope -> Scope -> NameMatch+nameMatch a b x@Special{} y@Special{} = x =~= y+nameMatch a b x y | isSpecial x || isSpecial y = False+nameMatch a b x y = unqual x =~= unqual y && not (null $ possModules a x `intersect` possModules b y)+++-- given A B x, return y such that A{x} == B{y}, if you can+nameQualify :: Scope -> Scope -> QName S -> QName S+nameQualify a (Scope b) x+    | isSpecial x = x+    | null imps = head $ real ++ [x]+    | any (not . importQualified) imps = unqual x+    | otherwise = Qual an (head $ mapMaybe importAs imps ++ map importModule imps) $ fromQual 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+        real = [Qual an (ModuleName an m) $ fromQual x | m <- possModules a x]+        imps = [i | r <- real, i <- b, possImport i r] ++-- which modules could a name possibly lie in+-- if it's qualified but not matching any import, assume the user+-- just lacks an import+possModules :: Scope -> QName S -> [String]+possModules (Scope is) x = f x+    where+        res = [fromModuleName $ importModule i | i <- is, possImport i x]++        f Special{} = [""]+        f x@(Qual _ mod _) = [fromModuleName mod | null res] ++ res+        f _ = res+++possImport :: ImportDecl S -> QName S -> Bool+possImport i Special{} = False+possImport i (Qual _ mod x) = fromModuleName mod `elem` map fromModuleName ms && possImport i{importQualified=False} (UnQual an x)+    where ms = importModule i : maybeToList (importAs i)+possImport i (UnQual _ x) = not (importQualified i) && maybe True f (importSpecs i)+    where+        f (ImportSpecList _ hide xs) = if hide then Just True `notElem` ms else Nothing `elem` ms || Just True `elem` ms+            where ms = map g xs+        +        g :: ImportSpec S -> Maybe Bool -- does this import cover the name x+        g (IVar _ y) = Just $ x =~= y+        g (IAbs _ y) = Just $ x =~= y+        g (IThingAll _ y) = if x =~= y then Just True else Nothing+        g (IThingWith _ y ys) = Just $ x `elem_` (y : map fromCName ys)+        +        fromCName :: CName S -> Name S+        fromCName (VarName _ x) = x+        fromCName (ConName _ x) = x
src/HSE/Util.hs view
@@ -34,6 +34,9 @@ modulePragmas :: Module_ -> [ModulePragma S] modulePragmas (Module _ _ x _ _) = x +fromModuleName :: ModuleName S -> String+fromModuleName (ModuleName _ x) = x+ isChar :: Exp_ -> Bool isChar (Lit _ Char{}) = True isChar _ = False@@ -105,7 +108,13 @@ unqual (Qual an _ x) = UnQual an x unqual x = x +fromQual :: QName S -> Name S+fromQual (Qual _ _ x) = x+fromQual (UnQual _ x) = x +isSpecial :: QName S -> Bool+isSpecial Special{} = True; isSpecial _ = False+ isDol :: QOp S -> Bool isDol (QVarOp _ (UnQual _ (Symbol _ "$"))) = True isDol _ = False@@ -138,8 +147,22 @@  getEquations :: Decl s -> [Decl s] getEquations (FunBind s xs) = map (FunBind s . (:[])) xs-getEquations (PatBind s (PVar _ name) _ bod bind) = [FunBind s [Match s name [] bod bind]]+getEquations x@PatBind{} = [toFunBind x] getEquations x = [x]+++toFunBind :: Decl s -> Decl s+toFunBind (PatBind s (PVar _ name) _ bod bind) = FunBind s [Match s name [] bod bind]+toFunBind x = x+++fromGuardedAlts :: GuardedAlts s -> Rhs s+fromGuardedAlts (UnGuardedAlt s x) = UnGuardedRhs s x+fromGuardedAlts (GuardedAlts s xs) = GuardedRhss s [GuardedRhs a b c | GuardedAlt a b c <- xs]++toGuardedAlts :: Rhs s -> GuardedAlts s+toGuardedAlts (UnGuardedRhs s x) = UnGuardedAlt s x+toGuardedAlts (GuardedRhss s xs) = GuardedAlts s [GuardedAlt a b c | GuardedRhs a b c <- xs]   -- case and if both have branches, nothing else does
src/Hint/Bracket.hs view
@@ -26,6 +26,7 @@ foo :: Int -> (Int -> Int) -- @Warning Int -> Int -> Int foo :: (Maybe Int) -> a -- @Warning Maybe Int -> a instance Named (DeclHead S)+data Foo = Foo {foo :: (Maybe Foo)} -- @Warning foo :: Maybe Foo  -- pattern bracket reduction foo (True) = 1@@ -56,7 +57,8 @@ bracketHint _ _ x =     concatMap (\x -> bracket True x ++ dollar x) (childrenBi x :: [Exp_]) ++     concatMap (bracket False) (childrenBi x :: [Type_]) ++-    concatMap (bracket False) (childrenBi x :: [Pat_])+    concatMap (bracket False) (childrenBi x :: [Pat_]) +++    concatMap fieldDecl (childrenBi x)   bracket :: (Annotated a, Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => Bool -> a S -> [Idea]@@ -72,6 +74,12 @@          g :: (Annotated a, Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => a S -> [Idea]         g o = concat [f (Just (i,o,gen)) x | (i,(x,gen)) <- zip [0..] $ holes o]+++fieldDecl :: FieldDecl S -> [Idea]+fieldDecl o@(FieldDecl a b (UnBangedTy c (TyParen _ d)))+    = [warn "Redundant bracket" o (FieldDecl a b (UnBangedTy c d))]+fieldDecl _ = []   dollar :: Exp_ -> [Idea]
src/Hint/Lambda.hs view
@@ -20,7 +20,9 @@  <TEST> f a = \x -> x + x -- f a x = x + x+f a = \a -> a + a -- f _ a = a + a f a = \x -> x + x where _ = test+f = \x -> x + x -- f x = x + x fun x y z = f x y z -- fun = f fun x y z = f x x y z -- fun x = f x x fun x y z = f g z -- fun x y = f g@@ -36,18 +38,20 @@ f = foo (\x -> x * y) -- (* y) f = foo (\x -> x # y) f = foo (\x -> \y -> x x y y) -- \x y -> x x y y-f = foo (\x -> \x -> foo x x)+f = foo (\x -> \x -> foo x x) -- \_ x -> foo x x+f = foo (\(x:xs) -> \x -> foo x x) -- \(_:xs) x -> foo x x+f = foo (\x -> \y -> \z -> x x y y z z) -- \x y z -> x x y y z z x ! y = fromJust $ lookup x y f = foo (\i -> writeIdea (getClass i) i) f = bar (flip Foo.bar x) -- (`Foo.bar` x) f = a b (\x -> c x d)  -- (`c` d)-yes = \x -> a x -- a-yes = \x y -> op y x -- flip op-f = \y -> nub $ reverse y -- nub . reverse-f = \z -> foo $ bar $ baz z -- foo . bar . baz-f = \z -> foo $ bar x $ baz z -- foo . bar x . baz-f = \z -> foo $ z $ baz z-f = \x -> bar map (filter x) -- bar map . filter+yes = \x -> a x where -- a+yes = \x y -> op y x where -- flip op+f = \y -> nub $ reverse y where -- nub . reverse+f = \z -> foo $ bar $ baz z where -- foo . bar . baz+f = \z -> foo $ bar x $ baz z where -- foo . bar x . baz+f = \z -> foo $ z $ baz z where+f = \x -> bar map (filter x) where -- bar map . filter f = bar &+& \x -> f (g x) foo = [\column -> set column [treeViewColumnTitle := printf "%s (match %d)" name (length candidnates)]] foo = [\x -> x]@@ -67,8 +71,8 @@   lambdaDecl :: Decl_ -> [Idea]-lambdaDecl o@(FunBind _ [Match _ name pats (UnGuardedRhs _ bod) Nothing])-    | Lambda _ vs y <- bod = [err "Redundant lambda" o $ reform (pats++vs) y]+lambdaDecl (toFunBind -> o@(FunBind _ [Match _ name pats (UnGuardedRhs _ bod) Nothing]))+    | isLambda $ fromParen bod = [err "Redundant lambda" o $ uncurry reform $ fromLambda $ Lambda an pats bod]     | (pats2,bod2) <- etaReduce pats bod, length pats2 < length pats = [err "Eta reduce" o $ reform pats2 bod2]         where reform p b = FunBind an [Match an name p (UnGuardedRhs an b) Nothing] lambdaDecl _ = []@@ -88,6 +92,14 @@     [warn "Use section" o $ RightSection an (QVarOp an x) y] lambdaExp p o@Lambda{} | maybe True (not . isInfixApp) p, res <- niceLambda [] o, not $ isLambda res =     [warn "Avoid lambda" o res]-lambdaExp p o@(Lambda _ ps1 (fromParen -> Lambda _ ps2 bod)) | pvars ps1 `disjoint` pvars ps2 =-    [warn "Collapse lambdas" o $ Lambda an (ps1++ps2) bod]+lambdaExp p o@(Lambda _ _ x) | isLambda (fromParen x) && maybe True (not . isLambda) p =+    [warn "Collapse lambdas" o $ uncurry (Lambda an) $ fromLambda o] lambdaExp _ _ = []+++-- replace any repeated pattern variable with _+fromLambda :: Exp_ -> ([Pat_], Exp_)+fromLambda (Lambda _ ps1 (fromLambda . fromParen -> (ps2,x))) = (transformBi (f $ pvars ps2) ps1 ++ ps2, x)+    where f bad x@PVar{} | prettyPrint x `elem` bad = PWildCard an+          f bad x = x+fromLambda x = ([], x)
src/Hint/Match.hs view
@@ -38,6 +38,7 @@ import Data.Data import Unsafe.Coerce import Settings+import HSE.NameMatch import Hint.Type import Control.Monad import Control.Arrow@@ -75,18 +76,19 @@ --------------------------------------------------------------------- -- PERFORM THE MATCHING -findIdeas :: [Setting] -> NameMatch -> Module S -> Decl_ -> [Idea]-findIdeas matches nm _ decl =+findIdeas :: [Setting] -> Scope -> Module S -> Decl_ -> [Idea]+findIdeas matches s _ decl =   [ idea (rankS m) (hintS m) x y   | (parent,x) <- universeParentExp decl, not $ isParen x, let x2 = fmapAn x-  , m <- matches, Just y <- [matchIdea nm decl m parent x2]]+  , m <- matches, Just y <- [matchIdea s decl m parent x2]]  -matchIdea :: NameMatch -> Decl_ -> Setting -> Maybe (Int, Exp_) -> Exp_ -> Maybe Exp_-matchIdea nm decl MatchExp{lhs=lhs,rhs=rhs,side=side} parent x = do+matchIdea :: Scope -> Decl_ -> Setting -> Maybe (Int, Exp_) -> Exp_ -> Maybe Exp_+matchIdea s decl MatchExp{lhs=lhs,rhs=rhs,side=side,scope=scope} parent x = do+    let nm = nameMatch scope s     u <- unifyExp nm lhs x     u <- check u-    let res = addBracket parent $ unqualify nm $ performEval $ subst u rhs+    let res = addBracket parent $ unqualify scope s $ performEval $ subst u rhs     guard $ checkSide side $ ("original",x) : ("result",res) : u     guard $ checkDefine decl parent res     return res@@ -203,11 +205,8 @@   -- contract Data.List.foo ==> foo, if Data.List is loaded-unqualify :: NameMatch -> Exp_ -> Exp_-unqualify nm = transformBi f-    where-        f (Qual _ mod x) | nm (Qual an mod x) (UnQual an x) = UnQual an x-        f x = x+unqualify :: Scope -> Scope -> Exp_ -> Exp_+unqualify from to = transformBi (nameQualify from to)   addBracket :: Maybe (Int,Exp_) -> Exp_ -> Exp_
src/Hint/Naming.hs view
@@ -19,6 +19,7 @@ no = 1 where yes_foo = 2 a -== b = 1 myTest = 1; my_test = 1+semiring'laws = 1 -- semiringLaws = ... </TEST> -} @@ -82,7 +83,7 @@             where (us,ys) = span (== '_') xs          g x | x `elem` ["_","'","_'"] = x-        g ('_':x:xs) | isAlphaNum x = toUpper x : g xs+        g (a:x:xs) | a `elem` "_'" && isAlphaNum x = toUpper x : g xs         g (x:xs) | isAlphaNum x = x : g xs                  | otherwise = g xs         g [] = []
src/Hint/Structure.hs view
@@ -5,6 +5,7 @@  <TEST> yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e+x `yes` y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e no x y = if a then b else c 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@@ -13,6 +14,10 @@ foo b | c <- f b = c where foo = b foo b | c <- f b = c \       | 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+foo x | a = b | True = d -- foo x | a = b ; | otherwise = d </TEST> -} @@ -25,29 +30,55 @@   structureHint :: DeclHint-structureHint _ _ x = concat [concatMap useGuards xs | FunBind _ xs <- [x]]+structureHint _ _ x = concatMap (uncurry hints . swap) $ asPattern x  -useGuards :: Match S -> [Idea]-useGuards x@(Match a b c (UnGuardedRhs d bod) e) -    | length guards > 2 = [warn "Use guards" x x2]-    where-        guards = asGuards bod-        x2 = Match a b c (GuardedRhss d guards) e+hints :: (String -> Pattern -> Idea) -> Pattern -> [Idea]+hints gen (Pattern pat (UnGuardedRhs d bod) bind)+    | length guards > 2 = [gen "Use guards" $ Pattern pat (GuardedRhss d guards) bind]+    where guards = asGuards bod -useGuards o@(Match sl b pats (GuardedRhss _ [GuardedRhs _ [Generator _ pat (App _ op (view -> Var_ p))] bod]) decs)+hints gen (Pattern pats (GuardedRhss _ [GuardedRhs _ [Generator _ pat (App _ op (view -> Var_ p))] bod]) bind)     | Just i <- findIndex (=~= (toNamed p :: Pat_)) pats-    , p `notElem` (vars bod ++ vars decs)+    , p `notElem` (vars bod ++ vars bind)     , vars op `disjoint` decsBind, pvars pats `disjoint` vars op, pvars pat `disjoint` pvars pats-    = [warn "Use view patterns" o $-       Match sl b (take i pats ++ [PParen an $ PViewPat an op pat] ++ drop (i+1) pats) (UnGuardedRhs an bod) decs]+    = [gen "Use view patterns" $+       Pattern (take i pats ++ [PParen an $ PViewPat an op pat] ++ drop (i+1) pats) (UnGuardedRhs an bod) bind]     where-        decsBind = nub $ concatMap declBind $ childrenBi decs+        decsBind = nub $ concatMap declBind $ childrenBi bind -useGuards _ = []+hints gen (Pattern pats (GuardedRhss _ [GuardedRhs _ [test] bod]) bind)+    | prettyPrint test `elem` ["otherwise","True"]+    = [gen "Redundant guard" $ Pattern pats (UnGuardedRhs an bod) bind] +hints gen (Pattern pats bod (Just bind)) | f bind+    = [gen "Redundant where" $ Pattern pats bod Nothing]+    where+        f (BDecls _ x) = null x+        f (IPBinds _ x) = null x +hints gen (Pattern pats (GuardedRhss _ (unsnoc -> (gs, GuardedRhs _ [test] bod))) bind)+    | prettyPrint test == "True"+    = [gen "Use otherwise" $ Pattern pats (GuardedRhss an $ gs ++ [GuardedRhs an [Qualifier an $ toNamed "otherwise"] bod]) bind]++hints _ _ = []++ asGuards :: Exp_ -> [GuardedRhs S] asGuards (Paren _ x) = asGuards x asGuards (If _ a b c) = GuardedRhs an [Qualifier an a] b : asGuards c asGuards x = [GuardedRhs an [Qualifier an $ toNamed "otherwise"] x]+++data Pattern = Pattern [Pat_] (Rhs S) (Maybe (Binds S))++-- Invariant: Number of patterns may not change+asPattern :: Decl_ -> [(Pattern, String -> Pattern -> Idea)]+asPattern x = concatMap decl (universeBi x) ++ concatMap alt (universeBi x)+    where+        decl o@(PatBind a pat b rhs bind) = [(Pattern [pat] rhs bind, \msg (Pattern [pat] rhs bind) -> warn msg o $ PatBind a pat b rhs bind)]+        decl (FunBind _ xs) = map match xs+        decl _ = []+        match o@(Match a b pat rhs bind) = (Pattern pat rhs bind, \msg (Pattern pat rhs bind) -> warn msg o $ Match a b pat rhs bind)+        match o@(InfixMatch a p b ps rhs bind) = (Pattern (p:ps) rhs bind, \msg (Pattern (p:ps) rhs bind) -> warn msg o $ InfixMatch a p b ps rhs bind)+        alt o@(Alt a pat rhs bind) = [(Pattern [pat] (fromGuardedAlts rhs) bind, \msg (Pattern [pat] rhs bind) -> warn msg o $ Alt a pat (toGuardedAlts rhs) bind)]
src/Hint/Type.hs view
@@ -5,7 +5,7 @@ import Idea  -type DeclHint = NameMatch -> Module_ -> Decl_ -> [Idea]-type ModuHint = NameMatch -> Module_          -> [Idea]+type DeclHint = Scope -> Module_ -> Decl_ -> [Idea]+type ModuHint = Scope -> Module_          -> [Idea]  data Hint = DeclHint {declHint :: DeclHint} | ModuHint {moduHint :: ModuHint}
src/Settings.hs view
@@ -46,7 +46,7 @@  data Setting     = Classify {rankS :: Rank, hintS :: String, funcS :: FuncName}-    | MatchExp {rankS :: Rank, hintS :: String, lhs :: Exp_, rhs :: Exp_, side :: Maybe Exp_}+    | MatchExp {rankS :: Rank, hintS :: String, scope :: Scope, lhs :: Exp_, rhs :: Exp_, side :: Maybe Exp_}     | Builtin String -- use a builtin hint set     | Infix Fixity       deriving Show@@ -63,14 +63,15 @@ readSettings :: FilePath -> [FilePath] -> IO [Setting] readSettings dataDir xs = do     (builtin,mods) <- fmap unzipEither $ concatMapM (readHints dataDir) xs-    return $ map Builtin builtin ++ concatMap (concatMap readSetting . concatMap getEquations . moduleDecls) mods+    let f m = concatMap (readSetting $ moduleScope m) $ concatMap getEquations $ moduleDecls m+    return $ map Builtin builtin ++ concatMap f mods   -- Read a hint file, and all hint files it imports readHints :: FilePath -> FilePath -> IO [Either String Module_] readHints dataDir file = do     y <- parseResult $ parseFile (addInfix parseFlags) file-    ys <- concatMapM (f . fromNamed . importModule) $ moduleImports y+    ys <- concatM [f $ fromNamed $ importModule i | i <- moduleImports y, importPkg i == Just "hint"]     return $ Right y:ys     where         f x | "HLint.Builtin." `isPrefixOf` x = return [Left $ drop 14 x]@@ -78,21 +79,21 @@             | otherwise = readHints dataDir $ x <.> "hs"  -readSetting :: Decl_ -> [Setting]-readSetting (FunBind _ [Match _ (Ident _ (getRank -> Just rank)) pats (UnGuardedRhs _ bod) bind])+readSetting :: Scope -> Decl_ -> [Setting]+readSetting s (FunBind _ [Match _ (Ident _ (getRank -> Just rank)) pats (UnGuardedRhs _ bod) bind])     | InfixApp _ lhs op rhs <- bod, opExp op ~= "==>" =-        [MatchExp rank (if null names then defaultHintName else head names) (fromParen lhs) (fromParen rhs) (readSide $ childrenBi bind)]+        [MatchExp rank (if null names then defaultHintName else head names) s (fromParen lhs) (fromParen rhs) (readSide $ childrenBi bind)]     | otherwise = [Classify rank n func | n <- names2, func <- readFuncs bod]     where         names = filter notNull $ getNames pats bod         names2 = ["" | null names] ++ names -readSetting x@AnnPragma{} | Just y <- readPragma x = [y]-readSetting (PatBind an (PVar _ name) _ bod bind) = readSetting $ FunBind an [Match an name [] 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@InfixDecl{} = map Infix $ getFixity x-readSetting x = errorOn x "bad hint"+readSetting s x@AnnPragma{} | Just y <- readPragma x = [y]+readSetting s (PatBind an (PVar _ name) _ bod bind) = readSetting s $ FunBind an [Match an name [] bod bind]+readSetting s (FunBind an xs) | length xs /= 1 = concatMap (readSetting s . FunBind an . return) xs+readSetting s (SpliceDecl an (App _ (Var _ x) (Lit _ y))) = readSetting s $ FunBind an [Match an (toNamed $ fromNamed x) [PLit an y] (UnGuardedRhs an $ Lit an $ String an "" "") Nothing]+readSetting s x@InfixDecl{} = map Infix $ getFixity x+readSetting s x = errorOn x "bad hint"   -- return Nothing if it is not an HLint pragma, otherwise all the settings@@ -155,31 +156,29 @@ findSettings flags file = do     x <- parseResult $ parseFile flags file     let xs = concatMap (findSetting $ UnQual an) (moduleDecls x)-        s = unlines $ ["-- hints found in " ++ file] ++ xs ++ ["-- no hints found" | null xs]-    r <- do-        m <- parseResult $ parseString (addInfix flags) "INTERNAL ERROR (please report)" $ unlines xs-        return $ concatMap readSetting $ moduleDecls m+        s = unlines $ ["-- hints found in " ++ file] ++ map prettyPrint xs ++ ["-- no hints found" | null xs]+        r = concatMap (readSetting emptyScope) xs     return (s,r)  -findSetting :: (Name S -> QName S) -> Decl_ -> [String]+findSetting :: (Name S -> QName S) -> Decl_ -> [Decl_] findSetting qual (InstDecl _ _ _ (Just xs)) = concatMap (findSetting qual) [x | InsDecl _ x <- xs] findSetting qual (PatBind _ (PVar _ name) Nothing (UnGuardedRhs _ bod) Nothing) = findExp (qual name) [] bod findSetting qual (FunBind _ [InfixMatch _ p1 name ps rhs bind]) = findSetting qual $ FunBind an [Match an name (p1:ps) rhs bind] findSetting qual (FunBind _ [Match _ name ps (UnGuardedRhs _ bod) Nothing]) = findExp (qual name) [] $ Lambda an ps bod-findSetting _ x@InfixDecl{} = [ltrim $ prettyPrint x]+findSetting _ x@InfixDecl{} = [x] findSetting _ _ = []   -- given a result function name, a list of variables, a body expression, give some hints-findExp :: QName S -> [String] -> Exp_ -> [String]+findExp :: QName S -> [String] -> Exp_ -> [Decl_] findExp name vs (Lambda _ ps bod) | length ps2 == length ps = findExp name (vs++ps2) bod                                   | otherwise = []     where ps2 = [x | PVar_ x <- map view ps] findExp name vs Var{} = [] findExp name vs (InfixApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $ App an x $ Paren an $ App an y (toNamed "_hlint") -findExp name vs bod = ["warn = " ++ prettyPrint lhs ++ " ==> " ++ prettyPrint rhs]+findExp name vs bod = [PatBind an (toNamed "warn") Nothing (UnGuardedRhs an $ InfixApp an lhs (toNamed "==>") rhs) Nothing]     where         lhs = g $ transform f bod         rhs = apps $ Var an name : map snd rep
src/Test.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}  module Test(test) where -import Control.Arrow import Control.Exception import Control.Monad import Data.Char import Data.List import Data.Maybe+import Data.Monoid import Data.Function import System.Directory import System.FilePath@@ -22,79 +22,120 @@ import HSE.All import Hint.All +data Result = Result {_failures :: Int, _total :: Int}+pass = Result 0 1+failure = Result 1 1+result x = if x then pass else failure+results = fmap mconcat --- Input, Output--- Output = Nothing, should not match--- Output = Just xs, should match xs-data Test = Test SrcLoc String (Maybe String)+instance Monoid Result where+    mempty = Result 0 0+    mappend (Result f1 t1) (Result f2 t2) = Result (f1+f2) (t1+t2) +progress = putChar '.'+failed xs = putStrLn $ unlines $ "" : xs -test :: FilePath -> IO Int-test dataDir = do-    dataLs <- getDirectoryContents dataDir -    src <- doesDirectoryExist "src/Hint"-    (fail,total) <- fmap ((sum *** sum) . unzip) $ sequence $-        [runTestDyn dataDir (dataDir </> h) | h <- dataLs, takeExtension h == ".hs", not $ "HLint" `isPrefixOf` takeBaseName h] ++-        [runTest [Builtin name] ("src/Hint" </> name <.> "hs") | (name,h) <- staticHints, src]-    unless src $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped"-    if fail == 0+test :: ([String] -> IO ()) -> FilePath -> [FilePath] -> IO Int+test main dataDir files = do+    Result failures total <-+        if null files then do+            src <- doesFileExist "hlint.cabal"+            res <- results $ sequence $ (if src then id else take 1)+                [testHintFiles dataDir, testSourceFiles, testInputOutput main]+            putStrLn ""+            unless src $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped"+            return res+        else do+            res <- results $ mapM (testHintFile dataDir) files+            putStrLn ""+            return res+    if failures == 0         then putStrLn $ "Tests passed (" ++ show total ++ ")"-        else putStrLn $ "Tests failed (" ++ show fail ++ " of " ++ show total ++ ")"-    return fail+        else putStrLn $ "Tests failed (" ++ show failures ++ " of " ++ show total ++ ")"+    return failures  -runTestDyn :: FilePath -> FilePath -> IO (Int,Int)-runTestDyn dataDir file = do-    settings <- readSettings dataDir [file]-    let bad = [putStrLn $ "No name for the hint " ++ prettyPrint (lhs x) | x@MatchExp{} <- settings, hintS x == defaultHintName]-    sequence_ bad+testHintFiles :: FilePath -> IO Result+testHintFiles dataDir = do+    xs <- getDirectoryContents dataDir+    results $ mapM (testHintFile dataDir)+        [dataDir </> x | x <- xs, takeExtension x == ".hs", not $ "HLint" `isPrefixOf` takeBaseName x] -    (f1,t1) <- runTestTypes settings-    (f2,t2) <- runTest settings file-    return (length bad + f1 + f2, t1 + t2) +testHintFile :: FilePath -> FilePath -> IO Result+testHintFile dataDir file = do+    hints <- readSettings dataDir [file]+    res <- results $ sequence $ nameCheckHints hints : checkAnnotations hints file :+                                [typeCheckHints hints | takeFileName file /= "Test.hs"]+    progress+    return res -runTestTypes :: [Setting] -> IO (Int,Int)-runTestTypes settings = bracket++testSourceFiles :: IO Result+testSourceFiles = fmap mconcat $ sequence+    [checkAnnotations [Builtin name] ("src/Hint" </> name <.> "hs") | (name,h) <- staticHints]+++testInputOutput :: ([String] -> IO ()) -> IO Result+testInputOutput main = do+    xs <- getDirectoryContents "tests"+    results $ mapM (checkInputOutput main) $ groupBy ((==) `on` takeBaseName) $ sort $ filter (not . isPrefixOf ".") xs+++---------------------------------------------------------------------+-- VARIOUS SMALL TESTS++nameCheckHints :: [Setting] -> IO Result+nameCheckHints hints = do+    let bad = [failed ["No name for the hint " ++ prettyPrint (lhs x)] | x@MatchExp{} <- hints, hintS x == defaultHintName]+    sequence_ bad+    return $ Result (length bad) 0+++-- | Given a set of hints, do all the MatchExp hints type check+typeCheckHints :: [Setting] -> IO Result+typeCheckHints hints = bracket     (openTempFile "." "hlinttmp.hs")     (\(file,h) -> removeFile file)     $ \(file,h) -> do         hPutStrLn h $ unlines contents         hClose h         res <- system $ "runhaskell " ++ file-        return (if res == ExitSuccess then 0 else 1, 1)+        progress+        return $ result $ res == ExitSuccess     where+        matches = filter isMatchExp hints+         contents =-            ["{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules #-}"-            ,"import System.IO"-            ,"import Control.Arrow"-            ,"import Data.Maybe"-            ,"import Control.Monad"-            ,"import Data.List"-            ,"import Data.Int"-            ,"import Data.Ord"-            ,"import Data.Monoid"-            ,"import Data.Function"-            ,"main = return ()"+            ["{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules #-}"] +++            concat (take 1 [map prettyPrint $ scopeImports $ scope x | x <- matches]) +++            ["main = return ()"             ,"(==>) :: a -> a -> a; (==>) = undefined"             ,"_noParen_ = id"-            ,"_eval_ = id"-            ,"bad = undefined"] ++-            [prettyPrint $ PatBind an (toNamed $ "test" ++ show i) Nothing bod Nothing-            | (i, MatchExp _ _ lhs rhs side) <- zip [1..] settings, "notTypeSafe" `notElem` vars side+            ,"_eval_ = id"] +++            ["{-# LINE " ++ show (startLine $ ann rhs) ++ " " ++ show (fileName $ ann rhs) ++ " #-}\n" +++             prettyPrint (PatBind an (toNamed $ "test" ++ show i) Nothing bod Nothing)+            | (i, MatchExp _ _ _ lhs rhs side) <- zip [1..] matches, "notTypeSafe" `notElem` vars side             , let vs = map toNamed $ nub $ filter isUnifyVar $ vars lhs ++ vars rhs             , let inner = InfixApp an (Paren an lhs) (toNamed "==>") (Paren an rhs)             , let bod = UnGuardedRhs an $ if null vs then inner else Lambda an vs inner]  --- return the number of fails/total-runTest :: [Setting] -> FilePath -> IO (Int,Int)-runTest setting file = do+---------------------------------------------------------------------+-- CHECK ANNOTATIONS++-- Input, Output+-- Output = Nothing, should not match+-- Output = Just xs, should match xs+data Test = Test SrcLoc String (Maybe String)++checkAnnotations :: [Setting] -> FilePath -> IO Result+checkAnnotations setting file = do     tests <- parseTestFile file     failures <- concatMapM f tests-    putStr $ unlines failures-    return (length failures, length tests)+    sequence_ failures+    return $ Result (length failures) (length tests)     where         f (Test loc inp out) = do             ideas <- applyHintStr parseFlags setting file inp@@ -104,12 +145,12 @@                               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"+            return [failed $+                ["TEST FAILURE (" ++ show (length ideas) ++ " hints generated)"+                ,"SRC: " ++ showSrcLoc loc+                ,"INPUT: " ++ inp] +++                map ((++) "OUTPUT: " . show) ideas +++                ["WANTED: " ++ fromMaybe "<failure>" out]                 | not good]          match "???" _ = True@@ -142,3 +183,34 @@     case dropWhile (/= "--") $ words x of         [] -> Nothing         _:xs -> Just $ unwords xs+++---------------------------------------------------------------------+-- CHECK INPUT/OUTPUT PAIRS++checkInputOutput :: ([String] -> IO ()) -> [FilePath] -> IO Result+checkInputOutput main xs = do+    let pre = takeBaseName $ head xs+        has x = (pre <.> x) `elem` xs+        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"+        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+    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)) "<EOF>"+        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
src/Util.hs view
@@ -18,7 +18,9 @@ import Data.Generics.Uniplate.Operations import Language.Haskell.Exts.Extension +import GHC.IO.Handle(hDuplicate,hDuplicateTo) + --------------------------------------------------------------------- -- SYSTEM.DIRECTORY @@ -45,6 +47,9 @@ concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f = liftM concat . mapM f +concatM :: Monad m => [m [a]] -> m [a]+concatM = liftM concat . sequence+ concatZipWithM :: Monad m => (a -> b -> m [c]) -> [a] -> [b] -> m [c] concatZipWithM f xs ys = liftM concat $ zipWithM f xs ys @@ -101,6 +106,13 @@   ---------------------------------------------------------------------+-- DATA.TUPLE++swap :: (a,b) -> (b,a)+swap (a,b) = (b,a)+++--------------------------------------------------------------------- -- SYSTEM.IO  readFileEncoding :: String -> FilePath -> IO String@@ -126,6 +138,29 @@ exitMessage msg = unsafePerformIO $ do     putStrLn msg     exitWith $ ExitFailure 1+++-- FIXME: This could use a lot more bracket calls!+captureOutput :: IO () -> IO String+captureOutput act = do+    tmp <- getTemporaryDirectory+    (f,h) <- openTempFile tmp "hlint"+    sto <- hDuplicate stdout+    ste <- hDuplicate stderr+    hDuplicateTo h stdout+    hDuplicateTo h stderr+    hClose h+    act+    hDuplicateTo sto stdout+    hDuplicateTo ste stderr+    res <- readFile' f+    removeFile f+    return res+++-- FIXME: Should use strict ByteString+readFile' :: FilePath -> IO String+readFile' x = listM' =<< readFile x   ---------------------------------------------------------------------