packages feed

hlint 1.8.7 → 1.8.8

raw patch · 21 files changed

+239/−74 lines, 21 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

data/Default.hs view
@@ -2,6 +2,7 @@ module HLint.Default where  import Control.Arrow+import Control.Exception import Control.Monad import Data.Function import Data.Int@@ -30,12 +31,12 @@  -- ORD -error = not (a == b) ==> a /= b-error = not (a /= b) ==> a == b-error = not (a >  b) ==> a <= b-error = not (a >= b) ==> a <  b-error = not (a <  b) ==> a >= b-error = not (a <= b) ==> a >  b+error = not (a == b) ==> a /= b where note = "incorrect if either value is NaN"+error = not (a /= b) ==> a == b where note = "incorrect if either value is NaN"+error = not (a >  b) ==> a <= b where note = "incorrect if either value is NaN"+error = not (a >= b) ==> a <  b where note = "incorrect if either value is NaN"+error = not (a <  b) ==> a >= b where note = "incorrect if either value is NaN"+error = not (a <= b) ==> a >  b where note = "incorrect if either value is NaN" error = compare x y /= GT ==> x <= y error = compare x y == LT ==> x < y error = compare x y /= LT ==> x >= y@@ -74,7 +75,7 @@ error = and (map p x) ==> all p x error = zipWith (,) ==> zip error = zipWith3 (,,) ==> zip3-warn  = length x == 0 ==> null x+warn  = length x == 0 ==> null x where note = "increases laziness" warn  "Use null" = length x /= 0 ==> not (null x) error "Use :" = (\x -> [x]) ==> (:[]) error = map (uncurry f) (zip x y) ==> zipWith f x y@@ -103,8 +104,8 @@ error = (\x -> x) ==> id error = (\(_,y) -> y) ==> snd error = (\(x,_) -> x) ==> fst-error = (\x y-> f (x,y)) ==> curry f where _ = notIn [x,y] f-error = (\(x,y) -> f x y) ==> uncurry f where _ = notIn [x,y] f+warn "Use curry" = (\x y-> f (x,y)) ==> curry f where _ = notIn [x,y] f+warn "Use uncurry" = (\(x,y) -> f x y) ==> uncurry f where _ = notIn [x,y] f error "Redundant $" = (($) . f) ==> f error "Redundant $" = (f $) ==> f warn  = (\x -> y) ==> const y where _ = isAtom y && notIn x y@@ -147,8 +148,10 @@ error "Monad law, left identity" = return a >>= f ==> f a error "Monad law, right identity" = m >>= return ==> m warn  = m >>= return . f ==> fmap f m-error = (if x then y else return ()) ==> Control.Monad.when x $ _noParen_ y-error = (if x then return () else y) ==> Control.Monad.unless x $ _noParen_ y+error = (if x then y else return ()) ==> Control.Monad.when x $ _noParen_ y where _ = not (isAtom y)+error = (if x then y else return ()) ==> Control.Monad.when x y where _ = isAtom y+error = (if x then return () else y) ==> Control.Monad.unless x $ _noParen_ y where _ = not (isAtom y)+error = (if x then return () else y) ==> Control.Monad.unless x y where _ = isAtom y error = sequence (map f x) ==> mapM f x error = sequence_ (map f x) ==> mapM_ f x warn  = flip mapM ==> Control.Monad.forM@@ -207,6 +210,8 @@  -- MATHS +error "Redundant fromIntegral" = fromIntegral x ==> x where _ = isLitInt x+error "Redundant fromInteger" = fromInteger x ==> x where _ = isLitInt x warn  = x + negate y ==> x - y warn  = 0 - x ==> negate x warn  = log y / log x ==> logBase x y@@ -217,8 +222,19 @@ warn  = n `rem` 2 /= 0 ==> odd n warn  = not (even x) ==> odd x warn  = not (odd x) ==> even x+warn  = x ** 0.5 ==> sqrt x+warn  = x ^^ y ==> x ** y where _ = isLitInt y warn  "Use 1" = x ^ 0 ==> 1 +-- EXCEPTION++error "Use Control.Exception.catch" = Prelude.catch ==> Control.Exception.catch where note = "Prelude.catch does not catch most exceptions"+warn = flip Control.Exception.catch ==> handle+warn = flip (catchJust p) ==> handleJust p+warn = Control.Exception.bracket b (const a) (const t) ==> Control.Exception.bracket_ b a t+warn = Control.Exception.bracket (openFile x y) hClose ==> withFile x y+warn = Control.Exception.bracket (openBinaryFile x y) hClose ==> withBinaryFile x y+ -- EVALUATE  -- TODO: These should be moved in to HSE\Evaluate.hs and applied@@ -268,7 +284,10 @@     where _ = (isAtom f || isApp f) && notIn a g -} +test = hints named test are to allow people to put test code within hint files+testPrefix = and any prefix also works + {- <TEST> yes = concat . map f -- concatMap f@@ -301,6 +320,7 @@     -- if nullPS s || (headPS s /= '\n') then return False else alter_input tailPS >> return True yes = if foo then do stuff; moreStuff; lastOfTheStuff else return () \     -- Control.Monad.when foo $ do stuff ; moreStuff ; lastOfTheStuff+yes = if foo then stuff else return () -- Control.Monad.when foo stuff yes = foo $ \(a, b) -> (a, y + b) -- Control.Arrow.second ((+) y) no  = foo $ \(a, b) -> (a, a + b) yes = map (uncurry (+)) $ zip [1 .. 5] [6 .. 10] -- zipWith (+) [1 .. 5] [6 .. 10]@@ -324,7 +344,7 @@ yes x = case x of {False -> a ; _ -> b} -- if x then b else a no = const . ok . toResponse $ "saved" yes = case x z of Nothing -> y z; Just pattern -> pattern -- fromMaybe (y z) (x z)-yes = if p then s else return () -- Control.Monad.when p $ s+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@@ -333,6 +353,14 @@ yes = [v | v <- xs] -- xs no  = [Left x | Left x <- xs] yes = Map.union a b -- a `Map.union` b+when p s = if p then s else return ()+yes = x ^^ 18 -- x ** 18+no = x ^^ 18.5+instance Arrow (->) where first f = f *** id+yes = fromInteger 12 -- 12+yes = catch -- Control.Exception.catch+import Prelude hiding (catch); no = catch+import Control.Exception as E; no = E.catch  import Prelude \ yes = flip mapM -- Control.Monad.forM
data/report_template.html view
@@ -112,6 +112,7 @@  #leftbar ul {margin-top: 0px; padding-left: 15px;} #leftbar p {margin-bottom: 0px;}+.note {color: gray; font-size: smaller;}  pre { 	font-family: "lucida console", monospace;
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.6 build-type:         Simple name:               hlint-version:            1.8.7+version:            1.8.8 -- license is GPL v2 only license:            GPL license-file:       LICENSE@@ -64,6 +64,7 @@         HSE.Util         Hint.All         Hint.Bracket+        Hint.Duplicate         Hint.Extensions         Hint.Import         Hint.Lambda
hlint.htm view
@@ -80,7 +80,7 @@ <h3 id="limitations">Bugs and limitations</h3>  <p>-	To report a bug either <a href="http://community.haskell.org/~ndm/contact/">email me</a>, or add the issue directly to <a href="http://code.google.com/p/ndmitchell/issues/list?q=proj:HLint">the bug tracker</a>. There are two common issues that I do not intend to fix:+	To report a bug either <a href="http://community.haskell.org/~ndm/contact/">email me</a>, or add the issue directly to <a href="http://code.google.com/p/ndmitchell/issues/list?q=proj:HLint">the bug tracker</a>. There are three common issues that I do not intend to fix: </p> <ul> 	<li>The presence of <tt>seq</tt> may cause some hints (i.e. eta-reduction) to change the semantics of a program.</li>@@ -137,7 +137,7 @@ <h3>Language Extensions</h3>  <p>-	HLint enables most Haskell extensions, disabling only those which steal too much syntax (currently Arrows, TransformListComp, XmlSyntax and RegularPatterns). Extensions can be enabled with <tt>-XArrows</tt>, and disabled with <tt>-XNoMagicHash</tt>. The flag <tt>-XHaskell98</tt> selects Haskell 98 compatibility.+	HLint enables most Haskell extensions, disabling only those which steal too much syntax (currently Arrows, TransformListComp, XmlSyntax and RegularPatterns). Individual extensions can be enabled or disabled with, for instance, <tt>-XArrows</tt>, or <tt>-XNoMagicHash</tt>. The flag <tt>-XHaskell98</tt> selects Haskell 98 compatibility. </p>  <h3 id="emacs">Emacs Integration</h3>@@ -166,7 +166,7 @@ 	If your version of GHC does not support the GHC threaded runtime then install with the command: <tt>cabal install --flags="-threaded"</tt> </p> -<h3>C preprocesor support</h3>+<h3>C preprocessor support</h3>  <p> 	HLint runs the <a href="http://hackage.haskell.org/package/cpphs">cpphs C preprocessor</a> over all input files, by default using the current directory as the include path with no defined macros. These settings can be modified using the flags <tt>--cpp-include</tt> and <tt>--cpp-define</tt>. To disable the C preprocessor use the flag <tt>-XNoCPP</tt>. There are a number of limitations to the C preprocessor support:
src/CmdLine.hs view
@@ -26,7 +26,7 @@ -- FIXME: Hints vs GivenHints is horrible data Cmd = Cmd     {cmdTest :: Bool                 -- ^ run in test mode?-    ,cmdFiles :: [FilePath]          -- ^ which files to run it on+    ,cmdFiles :: Maybe [FilePath]    -- ^ which files to run it on, nothing = none given     ,cmdHintFiles :: [FilePath]      -- ^ which settingsfiles to use     ,cmdGivenHints :: [FilePath]     -- ^ which settignsfiles were explicitly given     ,cmdReports :: [FilePath]        -- ^ where to generate reports@@ -102,7 +102,7 @@      let exts = [x | Ext x <- opt]         exts2 = if null exts then ["hs","lhs"] else exts-    files <- concatMapM (getFile exts2) files+    files <- if null files then return Nothing else fmap Just $ concatMapM (getFile exts2) files     findHints <- concatMapM (getFile exts2) [x | FindHints x <- opt]      let hintFiles = [x | Hints x <- opt]
src/HLint.hs view
@@ -4,6 +4,7 @@  import Control.Monad import Data.List+import Data.Maybe  import CmdLine import Settings@@ -48,10 +49,12 @@     let flags = parseFlags{cppFlags=cmdCpp, encoding=cmdEncoding, language=cmdLanguage}     if cmdTest then         test (\x -> hlint x >> return ()) cmdDataDir cmdGivenHints >> return []-     else if null cmdFiles && notNull cmdFindHints then+     else if isNothing cmdFiles && notNull cmdFindHints then         mapM_ (\x -> putStrLn . fst =<< findSettings flags x) cmdFindHints >> return []-     else if null cmdFiles then+     else if isNothing cmdFiles then         exitWithHelp+     else if cmdFiles == Just [] then+        error "No files found"      else         runHints cmd flags @@ -64,7 +67,7 @@     settings3 <- return [Classify Ignore x ("","") | x <- cmdIgnore]     let settings = settings1 ++ settings2 ++ settings3 -    ideas <- fmap concat $ parallel [listM' =<< applyHint flags settings x | x <- cmdFiles]+    ideas <- fmap concat $ parallel [listM' =<< applyHint flags settings x | x <- fromMaybe [] cmdFiles]     let (showideas,hideideas) = partition (\i -> cmdShowAll || severity i /= Ignore) ideas     showItem <- if cmdColor then showANSI else return show     mapM_ (outStrLn . showItem) showideas
src/HSE/Bracket.hs view
@@ -49,7 +49,7 @@         | Tuple{} <- parent = False         | If{} <- parent, isAnyApp child = False         | App{} <- parent, i == 0, App{} <- child = False-        | ExpTypeSig{} <- parent, i == 0, not $ isLambda child = False+        | ExpTypeSig{} <- parent, i == 0, isApp child = False         | Paren{} <- parent = False         | isDotApp parent, isDotApp child, i == 1 = False         | RecConstr{} <- parent = False
src/HSE/Util.hs view
@@ -5,6 +5,7 @@ import Control.Monad import Data.List import Data.Maybe+import System.FilePath import HSE.Type import Language.Haskell.Exts.Annotated.Simplify(sOp, sAssoc) @@ -250,7 +251,10 @@ -- SRCLOC FUNCTIONS  showSrcLoc :: SrcLoc -> String-showSrcLoc (SrcLoc file line col) = file ++ ":" ++ show line ++ ":" ++ show col ++ ":"+showSrcLoc (SrcLoc file line col) = take 1 file ++ f (drop 1 file) ++ ":" ++ show line ++ ":" ++ show col+    where f (x:y:zs) | isPathSeparator x && isPathSeparator y = f $ x:zs+          f (x:xs) = x : f xs+          f [] = []  toSrcLoc :: SrcInfo si => si -> SrcLoc toSrcLoc = getPointLoc@@ -272,8 +276,9 @@  x /=~= y = not $ x =~= y -elem_ :: (Annotated f, Eq (f ())) => f S -> [f S] -> Bool+elem_, notElem_ :: (Annotated f, Eq (f ())) => f S -> [f S] -> Bool elem_ x = any (x =~=)+notElem_ x = not . elem_ x  nub_ :: (Annotated f, Eq (f ())) => [f S] -> [f S] nub_ = nubBy (=~=)
src/Hint/All.hs view
@@ -18,6 +18,7 @@ import Hint.Import import Hint.Pragma import Hint.Extensions+import Hint.Duplicate   staticHints :: [(String,Hint)]@@ -33,6 +34,7 @@     ,"Import"     + importHint     ,"Pragma"     + pragmaHint     ,"Extensions" + extensionsHint+    ,"Duplicate"  + duplicateHint     ]  dynamicHints :: [Setting] -> Hint
src/Hint/Bracket.hs view
@@ -21,6 +21,7 @@ no = \(x -> y) -> z yes = (`foo` (bar baz)) -- @Warning (`foo` bar baz) + -- type bracket reduction foo :: (Int -> Int) -> Int foo :: Int -> (Int -> Int) -- @Warning Int -> Int -> Int@@ -45,6 +46,7 @@ yes = (a b $ c d) ++ e -- a b (c d) ++ e no = (f . g $ a) ++ e no = quickCheck ((\h -> cySucc h == succ h) :: Hygiene -> Bool)+foo = (case x of y -> z; q -> w) :: Int </TEST> -}
+ src/Hint/Duplicate.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}++{-+Find bindings within a let, and lists of statements+If you have n the same, error out++<TEST>+main = do a; a; a; a+main = do a; a; a; a; a; a -- ???+main = do a; a; a; a; a; a; a -- ???+main = do (do b; a; a; a); do (do c; a; a; a) -- ???+main = do a; a; a; b; a; a; a -- ???+main = do a; a; a; b; a; a+foo = a where {a = 1; b = 2; c = 3}; bar = a where {a = 1; b = 2; c = 3} -- ???+</TEST>+-}+++module Hint.Duplicate(duplicateHint) where++import Hint.Type+import Control.Arrow+import Data.List hiding (find)+import qualified Data.Map as Map+++duplicateHint :: ModuHint+duplicateHint _ modu =+    dupes [y | Do _ y :: Exp S <- universeBi modu] +++    dupes [y | BDecls l y :: Binds S <- universeBi modu]+++dupes ys =+    [rawIdea+        (if length xs >= 5 then Error else Warning)+        "Reduce duplication" p1+        (unlines $ map (prettyPrint . fmap (const p1)) xs)+        ("Combine with " ++ showSrcLoc p2) ""+    | (p1,p2,xs) <- duplicateOrdered 3 $ map (map (toSrcLoc . ann &&& dropAnn)) ys]+++---------------------------------------------------------------------+-- DUPLICATE FINDING++-- | The position to return if we match at this point, and the map of where to go next+--   If two runs have the same vals, always use the first pos you find+data Dupe pos val = Dupe pos (Map.Map val (Dupe pos val))+++find :: Ord val => [val] -> Dupe pos val -> (pos, Int)+find (v:vs) (Dupe p mp) | Just d <- Map.lookup v mp = second (+1) $ find vs d+find _ (Dupe p mp) = (p, 0)+++add :: Ord val => pos -> [val] -> Dupe pos val -> Dupe pos val+add pos [] d = d+add pos (v:vs) (Dupe p mp) = Dupe p $ Map.insertWith f v (add pos vs $ Dupe pos Map.empty) mp+    where f new old = add pos vs old+++duplicateOrdered :: Ord val => Int -> [[(SrcLoc,val)]] -> [(SrcLoc,SrcLoc,[val])]+duplicateOrdered threshold xs = concat $ concat $ snd $ mapAccumL f (Dupe nullSrcLoc Map.empty) xs+    where+        f d xs = second overlaps $ mapAccumL (g pos) d $ takeWhile ((>= threshold) . length) $ tails xs+            where pos = Map.fromList $ zip (map fst xs) [0..]++        g pos d xs = (d2, res)+            where+                res = [(p,pme,take mx vs) | i >= threshold+                      ,let mx = maybe i (\x -> min i $ (pos Map.! pme) - x) $ Map.lookup p pos+                      ,mx >= threshold]+                vs = map snd xs+                (p,i) = find vs d+                pme = fst $ head xs+                d2 = add pme vs d++        overlaps (x@((_,_,n):_):xs) = x : overlaps (drop (length n - 1) xs)+        overlaps (x:xs) = x : overlaps xs+        overlaps [] = []
src/Hint/Extensions.hs view
@@ -26,7 +26,7 @@ {-# LANGUAGE RecordWildCards #-} \ record field = Record{..} {-# LANGUAGE RecordWildCards #-} \-record = 1 -- {-# LANGUAGE DisambiguateRecordFields #-}+record = 1 -- </TEST> -} @@ -42,6 +42,7 @@ extensionsHint :: ModuHint extensionsHint _ x = [rawIdea Error "Unused LANGUAGE pragma" (toSrcLoc sl)           (prettyPrint o) (if null new then "" else prettyPrint $ LanguagePragma sl $ map (toNamed . showExt) new)+          (warnings old new)     | not $ used TemplateHaskell x -- if TH is on, can use all other extensions programmatically     , o@(LanguagePragma sl exts) <- modulePragmas x     , let old = map (classifyExtension . prettyPrint) exts@@ -54,13 +55,13 @@  minimalExtensions :: Module_ -> [Extension] -> [Extension] minimalExtensions x es = nub $ concatMap f es-    where f e = if used e x then [e] else concatMap f $ implies e+    where f e = if used e x then [e] else []  --- sometimes one extension implies others, this captures that-implies :: Extension -> [Extension]-implies RecordWildCards = [DisambiguateRecordFields]-implies _ = []+-- RecordWildCards implies DisambiguateRecordFields, but most people probably don't want it+warnings old new | RecordWildCards `elem` old && RecordWildCards `notElem` new = "you may need to add DisambiguateRecordFields"+warnings _ _ = ""+  used :: Extension -> Module_ -> Bool used RecursiveDo = hasS isMDo
src/Hint/Import.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternGuards, ScopedTypeVariables #-} {-     Reduce the number of import declarations.     Two import declarations can be combined if:@@ -30,6 +30,10 @@ import Char(foo) -- import Data.Char(foo) import IO(foo) import IO as X -- import System.IO as X; import System.IO.Error as X; import Control.Exception  as X (bracket,bracket_)+module Foo(module A, baz, module B, module C) where; import A; import D; import B(map,filter); import C \+    -- module Foo(baz, module X) where; import A as X; import B as X(map, filter); import C as X+module Foo(module A, baz, module B, module X) where; import A; import B; import X \+    -- module Foo(baz, module Y) where; import A as Y; import B as Y; import X as Y </TEST> -} @@ -38,17 +42,19 @@  import Hint.Type import Util+import Data.List import Data.Maybe   importHint :: ModuHint importHint _ x = concatMap (wrap . snd) (groupSortFst                  [((fromNamed $ importModule i,importPkg i),i) | i <- universeBi x, not $ importSrc i]) ++-                 concatMap hierarchy (universeBi x)+                 concatMap hierarchy (universeBi x) +++                 multiExport x   wrap :: [ImportDecl S] -> [Idea]-wrap o = [ rawIdea Error "Use fewer imports" (toSrcLoc $ ann $ head o) (f o) (f x)+wrap o = [ rawIdea Error "Use fewer imports" (toSrcLoc $ ann $ head o) (f o) (f x) ""          | Just x <- [simplify o]]     where f = unlines . map prettyPrint @@ -107,10 +113,10 @@ -- import IO is equivalent to -- import System.IO, import System.IO.Error, import Control.Exception(bracket, bracket_) hierarchy i@ImportDecl{importModule=ModuleName _ "IO", importSpecs=Nothing,importPkg=Nothing}-    = [rawIdea Warning "Use hierarchical imports" (toSrcLoc $ ann i) (ltrim $ prettyPrint i) $+    = [rawIdea Warning "Use hierarchical imports" (toSrcLoc $ ann i) (ltrim $ prettyPrint i) (           unlines $ map (ltrim . prettyPrint)           [f "System.IO" Nothing, f "System.IO.Error" Nothing-          ,f "Control.Exception" $ Just $ ImportSpecList an False [IVar an $ toNamed x | x <- ["bracket","bracket_"]]]]+          ,f "Control.Exception" $ Just $ ImportSpecList an False [IVar an $ toNamed x | x <- ["bracket","bracket_"]]]) ""]     where f a b = (desugarQual i){importModule=ModuleName an a, importSpecs=b}  hierarchy _ = []@@ -120,3 +126,24 @@ desugarQual :: ImportDecl S -> ImportDecl S desugarQual x | importQualified x && isNothing (importAs x) = x{importAs=Just (importModule x)}               | otherwise = x+++multiExport :: Module S -> [Idea]+multiExport x =+    [ rawIdea Warning "Use import/export shortcut" (toSrcLoc $ ann hd)+        (unlines $ prettyPrint hd : map prettyPrint imps)+        (unlines $ prettyPrint newhd : map prettyPrint newimps)+        ""+    | Module l (Just hd) _ imp _ <- [x]+    , let asNames = mapMaybe importAs imp+    , let expNames = [x | EModuleContents _ x <- childrenBi hd]+    , let imps = [i | i@ImportDecl{importAs=Nothing,importQualified=False,importModule=name} <- imp+                 ,name `notElem_` asNames, name `elem_` expNames]+    , length imps >= 3+    , let newname = ModuleName an $ head $ map return ("XYZ" ++ ['A'..]) \\+                                           [x | ModuleName (_ :: S) x <- universeBi hd ++ universeBi imp]+    , let reexport (EModuleContents _ x) = x `notElem_` map importModule imps+          reexport x = True+    , let newhd = descendBi (\xs -> filter reexport xs ++ [EModuleContents an newname]) hd+    , let newimps = [i{importAs=Just newname} | i <- imps]+    ]
src/Hint/Match.hs view
@@ -77,20 +77,21 @@  findIdeas :: [Setting] -> Scope -> Module S -> Decl_ -> [Idea] findIdeas matches s _ decl =-  [ idea (severityS m) (hintS m) x y-  | (parent,x) <- universeParentExp decl, not $ isParen x, let x2 = fmapAn x-  , m <- matches, Just y <- [matchIdea s decl m parent x2]]+  [ (idea (severityS m) (hintS m) x y){note=notes}+  | decl <- case decl of InstDecl{} -> children decl; _ -> [decl]+  , (parent,x) <- universeParentExp decl, not $ isParen x, let x2 = fmapAn x+  , m <- matches, Just (y,notes) <- [matchIdea s decl m parent x2]]  -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+matchIdea :: Scope -> Decl_ -> Setting -> Maybe (Int, Exp_) -> Exp_ -> Maybe (Exp_,String)+matchIdea s decl MatchExp{lhs=lhs,rhs=rhs,side=side,scope=scope,notes=notes} parent x = do     let nm = nameMatch scope s     u <- unifyExp nm lhs x     u <- check u     let res = addBracket parent $ unqualify scope s u $ performEval $ subst u rhs     guard $ checkSide side $ ("original",x) : ("result",res) : u     guard $ checkDefine decl parent res-    return res+    return (res,notes)   ---------------------------------------------------------------------@@ -174,12 +175,16 @@          f (App _ cond (sub -> y))             | 'i':'s':typ <- fromNamed cond-            = if typ == "Atom" then isAtom y else head (words $ show y) == typ+            = isType typ y         f (App _ (App _ cond (sub -> x)) (sub -> y))             | cond ~= "notIn" = and [x `notElem` universe y | x <- list x, y <- list y]             | cond ~= "notEq" = x /= y         f x | x ~= "notTypeSafe" = True         f x = error $ "Hint.Match.checkSide, unknown side condition: " ++ prettyPrint x++        isType "Atom" x = isAtom x+        isType ('L':'i':'t':typ@(_:_)) (Lit _ x) = head (words $ show x) == typ+        isType typ x = head (words $ show x) == typ          list :: Exp_ -> [Exp_]         list (List _ xs) = xs
src/Hint/Monad.hs view
@@ -20,13 +20,15 @@ yes = do x <- bar; x -- do join bar no = do x <- bar; x; x no = mdo hook <- mkTrigger pat (act >> rmHook hook) ; return hook-yes = do x <- return y; foo x -- do let x = y; foo x+yes = do x <- return y; foo x -- @Warning do let x = y; foo x yes = do x <- return $ y + z; foo x -- do let x = y + z; foo x no = do x <- return x; foo x no = do x <- return y; x <- return y; foo x yes = do forM files $ \x -> return (); return () -- forM_ files $ \x -> return () yes = do if a then forM x y else sequence z q; return () -- if a then forM_ x y else sequence_ z q yes = do case a of {_ -> forM x y; x:xs -> forM x xs}; return () -- case a of _ -> forM_ x y ; x:xs -> forM_ x xs+foldM_ f a xs = foldM f a xs >> return ()+folder f a xs = foldM f a xs >> return () -- foldM_ f a xs </TEST> -} @@ -43,19 +45,19 @@   monadHint :: DeclHint-monadHint _ _ = concatMap monadExp . universeBi+monadHint _ _ d = concatMap (monadExp d) $ universeBi d -monadExp :: Exp_ -> [Idea]-monadExp x = case x of+monadExp :: Decl_ -> Exp_ -> [Idea]+monadExp decl x = case x of         (view -> App2 op x1 x2) | op ~= ">>" -> f x1         Do _ xs -> [err "Redundant return" x y | Just y <- [monadReturn xs]] ++                    [err "Use join" x (Do an y) | Just y <- [monadJoin xs]] ++                    [err "Redundant do" x y | [Qualifier _ y] <- [xs]] ++-                   [err "Use let" x (Do an y) | Just y <- [monadLet xs]] +++                   [warn "Use let" x (Do an y) | Just y <- [monadLet xs]] ++                    concat [f x | Qualifier _ x <- init xs]         _ -> []     where-        f x = [err ("Use " ++ name) x y | Just (name,y) <- [monadCall x]]+        f x = [err ("Use " ++ name) x y | Just (name,y) <- [monadCall x], fromNamed decl /= name]   -- see through Paren and down if/case etc
src/Hint/Naming.hs view
@@ -3,7 +3,7 @@     Suggest the use of camelCase      Only permit:-    _*[A-Za-z]*_?'?+    _*[A-Za-z]*_*'*      Apply this to things that would get exported by default only     Also allow prop_ as it's a standard QuickCheck idiom@@ -77,8 +77,8 @@ suggestName :: String -> Maybe String suggestName x = listToMaybe [f x | not $ isSym x || good || not (any isLower x) || "prop_" `isPrefixOf` x]     where-        good = all isAlphaNum $ drp '_' $ drp '\'' $ reverse $ dropWhile (== '_') x-        drp x ys = if [x] `isPrefixOf` ys then tail ys else ys+        good = all isAlphaNum $ drp '_' $ drp '\'' $ reverse $ drp '_' x+        drp x = dropWhile (== x)          f xs = us ++ g ys             where (us,ys) = span (== '_') xs
src/Hint/Pragma.hs view
@@ -41,7 +41,7 @@   pragmaIdea :: [ModulePragma S] -> [ModulePragma S] -> Idea-pragmaIdea xs ys = rawIdea Error "Use better pragmas" (toSrcLoc $ ann $ head xs) (f xs) (f ys)+pragmaIdea xs ys = rawIdea Error "Use better pragmas" (toSrcLoc $ ann $ head xs) (f xs) (f ys) ""     where f = unlines . map prettyPrint
src/Idea.hs view
@@ -10,7 +10,7 @@   data Idea-    = Idea {func :: FuncName, severity :: Severity, hint :: String, loc :: SrcLoc, from :: String, to :: String}+    = Idea {func :: FuncName, severity :: Severity, hint :: String, loc :: SrcLoc, from :: String, to :: String, note :: String}     | ParseError {severity :: Severity, hint :: String, loc :: SrcLoc, msg :: String, from :: String}       deriving (Eq,Ord) @@ -29,15 +29,20 @@  showEx :: (String -> String) -> Idea -> String showEx tt Idea{..} = unlines $-    [showSrcLoc loc ++ " " ++ show severity ++ ": " ++ hint] ++ f "Found" from ++ f "Why not" to-    where f msg x = (msg ++ ":") : map ("  "++) (lines $ tt x)+    [showSrcLoc loc ++ ": " ++ show severity ++ ": " ++ hint] +++    f "Found" from ++ f "Why not" to +++    ["Note: " ++ note | note /= ""]+    where+        f msg x | null xs = [msg ++ " remove it."]+                | otherwise = (msg ++ ":") : map ("  "++) xs+            where xs = lines $ tt x  showEx tt ParseError{..} = unlines $-    [showSrcLoc loc ++ " Parse error","Error message:","  " ++ msg,"Code:"] ++ map ("  "++) (lines $ tt from)+    [showSrcLoc loc ++ ": Parse error","Error message:","  " ++ msg,"Code:"] ++ map ("  "++) (lines $ tt from)   rawIdea = Idea ("","")-idea severity hint from to = rawIdea severity hint (toSrcLoc $ ann from) (f from) (f to)+idea severity hint from to = rawIdea severity hint (toSrcLoc $ ann from) (f from) (f to) ""     where f = ltrim . prettyPrint warn = idea Warning err = idea Error
src/Report.hs view
@@ -51,18 +51,19 @@ writeIdea :: String -> Idea -> [String] writeIdea cls Idea{..} =     ["<div class=" ++ show cls ++ ">"-    ,escapeHTML (showSrcLoc loc ++ " " ++ show severity ++ ": " ++ hint) ++ "<br/>"+    ,escapeHTML (showSrcLoc loc ++ ": " ++ show severity ++ ": " ++ hint) ++ "<br/>"     ,"Found<br/>"     ,code from-    ,"Why not<br/>"+    ,"Why not" ++ (if to == "" then " remove it." else "") ++ "<br/>"     ,code to+    ,if note /= "" then "<span class='note'>Note: " ++ note ++ "</span>" else ""     ,"</div>"     ,""]   writeIdea cls ParseError{..} =     ["<div class=" ++ show cls ++ ">"-    ,escapeHTML (showSrcLoc loc ++ " " ++ show severity ++ ": " ++ hint) ++ "<br/>"+    ,escapeHTML (showSrcLoc loc ++ ": " ++ show severity ++ ": " ++ hint) ++ "<br/>"     ,"Error message<br/>"     ,"<pre>" ++ escapeHTML msg ++ "</pre>"     ,"Code<br/>"
src/Settings.hs view
@@ -50,7 +50,7 @@  data Setting     = Classify {severityS :: Severity, hintS :: String, funcS :: FuncName}-    | MatchExp {severityS :: Severity, hintS :: String, scope :: Scope, lhs :: Exp_, rhs :: Exp_, side :: Maybe Exp_}+    | MatchExp {severityS :: Severity, hintS :: String, scope :: Scope, lhs :: Exp_, rhs :: Exp_, side :: Maybe Exp_, notes :: String}     | Builtin String -- use a builtin hint set     | Infix Fixity       deriving Show@@ -86,12 +86,14 @@ readSetting :: Scope -> Decl_ -> [Setting] readSetting s (FunBind _ [Match _ (Ident _ (getSeverity -> Just severity)) pats (UnGuardedRhs _ bod) bind])     | InfixApp _ lhs op rhs <- bod, opExp op ~= "==>" =-        [MatchExp severity (if null names then defaultHintName else head names) s (fromParen lhs) (fromParen rhs) (readSide $ childrenBi bind)]+        let (a,b) = readSide $ childrenBi bind in+        [MatchExp severity (if null names then defaultHintName else head names) s (fromParen lhs) (fromParen rhs) a b]     | otherwise = [Classify severity n func | n <- names2, func <- readFuncs bod]     where         names = filter notNull $ getNames pats bod         names2 = ["" | null names] ++ names +readSetting s x | "test" `isPrefixOf` map toLower (fromNamed x) = [] 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@@ -116,10 +118,11 @@ readPragma _ = Nothing  -readSide :: [Decl_] -> Maybe Exp_-readSide [] = Nothing-readSide [PatBind _ PWildCard{} Nothing (UnGuardedRhs _ bod) Nothing] = Just bod-readSide (x:_) = errorOn x "bad side condition"+readSide :: [Decl_] -> (Maybe Exp_, String)+readSide = foldl f (Nothing,"")+    where f (Nothing,warn) (PatBind _ PWildCard{} Nothing (UnGuardedRhs _ side) Nothing) = (Just side, warn)+          f (side,"") (PatBind _ (fromNamed -> "note") Nothing (UnGuardedRhs _ (Lit _ (String _ warn _))) Nothing) = (side,warn)+          f _ x = errorOn x "bad side condition"   -- Note: Foo may be ("","Foo") or ("Foo",""), return both@@ -147,8 +150,8 @@  errorOn :: (Annotated ast, Pretty (ast S)) => ast S -> String -> b errorOn val msg = exitMessage $-    showSrcLoc (getPointLoc $ ann val)  ++-    " Error while reading hint file, " ++ msg ++ "\n" +++    showSrcLoc (getPointLoc $ ann val) +++    ": Error while reading hint file, " ++ msg ++ "\n" ++     prettyPrint val
src/Test.hs view
@@ -116,7 +116,7 @@             ,"_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+            | (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]@@ -200,19 +200,19 @@         else if has "lhs" then return ["tests/" ++ pre <.> "lhs"]         else error "checkInputOutput, couldn't find or figure out flags" -    got <- captureOutput $+    got <- fmap (fmap lines) $ captureOutput $         handle (\(e::SomeException) -> print $ e) $         handle (\(e::ExitCode) -> return ()) $         main flags-    want <- reader "output"+    want <- fmap lines $ reader "output" +    let eq w g = w == g || ("*" `isSuffixOf` w && init w `isPrefixOf` g)     case got of         Nothing -> putStrLn "Warning: failed to capture output (GHC too old?)" >> return pass-        Just got | got == want -> return pass+        Just got | length got == length want && and (zipWith eq want got) -> return pass                  | otherwise -> 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]+            let (i,g,w):_ = [(i,g,w) | (i,g,w) <- zip3 [1..] (got++trail) (want++trail), not $ eq g w]             putStrLn $ unlines                 ["TEST FAILURE IN tests/" ++ pre                 ,"DIFFER ON LINE: " ++ show i