packages feed

hlint 1.8.40 → 1.8.41

raw patch · 18 files changed

+373/−77 lines, 18 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

data/Default.hs view
@@ -4,18 +4,31 @@ import Control.Arrow import Control.Exception import Control.Monad-import Data.Foldable+import Control.Monad.State+import qualified Data.Foldable+import Data.Foldable(asum, sequenceA_, traverse_, for_)+import Data.Traversable(traverse, for)+import Control.Applicative import Data.Function import Data.Int+import Data.Char+import Data.List as Data.List import Data.List as X import Data.Maybe import Data.Monoid import System.IO+import Control.Concurrent.Chan+import System.Mem.Weak+import Control.Exception.Base+import System.Exit+import Data.Either+import Numeric  import IO as System.IO import List as Data.List import Maybe as Data.Maybe import Monad as Control.Monad+import Char as Data.Char  -- I/O @@ -48,8 +61,8 @@ error = compare x y == LT ==> x < y error = compare x y /= LT ==> x >= y error = compare x y == GT ==> x > y-error = x == a || x == b || x == c ==> x `elem` [a,b,c]-error = x /= a && x /= b && x /= c ==> x `notElem` [a,b,c]+error = x == a || x == b || x == c ==> x `elem` [a,b,c] where note = ValidInstance "Eq" x+error = x /= a && x /= b && x /= c ==> x `notElem` [a,b,c] where note = ValidInstance "Eq" x --error = compare (f x) (f y) ==> Data.Ord.comparing f x y -- not that great --error = on compare f ==> Data.Ord.comparing f -- not that great error = head (sort x) ==> minimum x@@ -68,17 +81,17 @@ -- LIST  error = concat (map f x) ==> concatMap f x-warn = concat [a,b] ==> a ++ b+warn = concat [a, b] ==> a ++ b warn "Use map once" = map f (map g x) ==> map (f . g) x warn  = x !! 0 ==> head x error = take n (repeat x) ==> replicate n x error = head (reverse x) ==> last x-error = head (drop n x) ==> x !! n where note = "if the index is non-negative"-error = reverse (tail (reverse x)) ==> init x-error = take (length x - 1) x ==> init x+error = head (drop n x) ==> x !! n where _ = isNat n+error = reverse (tail (reverse x)) ==> init x where note = IncreasesLaziness+-- error = take (length x - 1) x ==> init x -- not true for x == [] error = isPrefixOf (reverse x) (reverse y) ==> isSuffixOf x y error = foldr (++) [] ==> concat-error = foldl (++) [] ==> concat+error = foldl (++) [] ==> concat where note = IncreasesLaziness error = span (not . p) ==> break p error = break (not . p) ==> span p error = concatMap (++ "\n") ==> unlines@@ -87,9 +100,9 @@ error = and (map p x) ==> all p x error = zipWith (,) ==> zip error = zipWith3 (,,) ==> zip3-warn  = length x == 0 ==> null x where note = "increases laziness"+warn  = length x == 0 ==> null x where note = IncreasesLaziness warn  = x == [] ==> null x-warn  "Use null" = length x /= 0 ==> not (null x) where note = "increases laziness"+warn  "Use null" = length x /= 0 ==> not (null x) where note = IncreasesLaziness error "Use :" = (\x -> [x]) ==> (:[]) error = map (uncurry f) (zip x y) ==> zipWith f x y warn  = map f (zip x y) ==> zipWith (curry f) x y where _ = isVar f@@ -104,12 +117,12 @@ error = filter f x /= [] ==> any f x error = any id ==> or error = all id ==> and-error = any ((==) a) ==> elem a+error = any ((==) a) ==> elem a where note = ValidInstance "Eq" a error = any (== a) ==> elem a-error = any (a ==) ==> elem a-error = all ((/=) a) ==> notElem a-error = all (/= a) ==> notElem a-error = all (a /=) ==> notElem a+error = any (a ==) ==> elem a where note = ValidInstance "Eq" a+error = all ((/=) a) ==> notElem a where note = ValidInstance "Eq" a+error = all (/= a) ==> notElem a where note = ValidInstance "Eq" a+error = all (a /=) ==> notElem a where note = ValidInstance "Eq" a error = elem True ==> or error = notElem False ==> and error = findIndex ((==) a) ==> elemIndex a@@ -119,29 +132,33 @@ error = findIndices (a ==) ==> elemIndices a error = findIndices (== a) ==> elemIndices a error = lookup b (zip l [0..]) ==> elemIndex b l-warn "length always non-negative" = length x >= 0 ==> True-warn "Use null" = length x > 0 ==> not (null x) where note = "increases laziness"-warn "Use null" = length x >= 1 ==> not (null x) where note = "increases laziness"+warn "Length always non-negative" = length x >= 0 ==> True+warn "Use null" = length x > 0 ==> not (null x) where note = IncreasesLaziness+warn "Use null" = length x >= 1 ==> not (null x) where note = IncreasesLaziness+error "Take on a non-positive" = take i x ==> [] where _ = isNegZero i+error "Drop on a non-positive" = drop i x ==> x where _ = isNegZero i+error = (takeWhile p l, dropWhile p l) ==> span p l + -- FOLDS  error = foldr  (>>) (return ()) ==> sequence_ error = foldr  (&&) True ==> and-error = foldl  (&&) True ==> and-error = foldr1 (&&)  ==> and-error = foldl1 (&&)  ==> and+error = foldl  (&&) True ==> and where note = IncreasesLaziness+error = foldr1 (&&)  ==> and where note = RemovesError "on []"+error = foldl1 (&&)  ==> and where note = RemovesError "on []" error = foldr  (||) False ==> or-error = foldl  (||) False ==> or-error = foldr1 (||)  ==> or-error = foldl1 (||)  ==> or+error = foldl  (||) False ==> or where note = IncreasesLaziness+error = foldr1 (||)  ==> or where note = RemovesError "on []"+error = foldl1 (||)  ==> or where note = RemovesError "on []" error = foldl  (+) 0 ==> sum error = foldr  (+) 0 ==> sum-error = foldl1 (+)   ==> sum-error = foldr1 (+)   ==> sum+error = foldl1 (+)   ==> sum where note = RemovesError "on []"+error = foldr1 (+)   ==> sum where note = RemovesError "on []" error = foldl  (*) 1 ==> product error = foldr  (*) 1 ==> product-error = foldl1 (*)   ==> product-error = foldr1 (*)   ==> product+error = foldl1 (*)   ==> product where note = RemovesError "on []"+error = foldr1 (*)   ==> product where note = RemovesError "on []" error = foldl1 max   ==> maximum error = foldr1 max   ==> maximum error = foldl1 min   ==> minimum@@ -154,13 +171,13 @@ error = (\x y -> x) ==> const error = (\(x,y) -> y) ==> snd where _ = notIn x y error = (\(x,y) -> x) ==> fst where _ = notIn y x-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+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; note = IncreasesLaziness error "Redundant $" = (($) . f) ==> f error "Redundant $" = (f $) ==> f warn  = (\x -> y) ==> const y where _ = isAtom y && notIn x y error "Redundant flip" = flip f x y ==> f y x where _ = isApp original-warn  = (\a b -> o (f a) (f b)) ==> o `Data.Function.on` f+warn  = (\a b -> g (f a) (f b)) ==> g `Data.Function.on` f  -- CHAR @@ -174,9 +191,15 @@  -- BOOL -error "Redundant ==" = a == True ==> a-warn  "Redundant ==" = a == False ==> not a-error "Redundant if" = (if a then x else x) ==> x where note = "reduces strictness"+error "Redundant ==" = x == True ==> x+warn  "Redundant ==" = x == False ==> not x+error "Redundant ==" = True == a ==> a+warn  "Redundant ==" = False == a ==> not a+error "Redundant /=" = a /= True ==> not a+warn  "Redundant /=" = a /= False ==> a+error "Redundant /=" = True /= a ==> not a+warn  "Redundant /=" = False /= a ==> a+error "Redundant if" = (if a then x else x) ==> x where note = IncreasesLaziness error "Redundant if" = (if a then True else False) ==> a error "Redundant if" = (if a then False else True) ==> not a error "Redundant if" = (if a then t else (if b then t else f)) ==> if a || b then t else f@@ -187,16 +210,16 @@ warn  "Use if" = case a of {False -> f; True -> t} ==> if a then t else f warn  "Use if" = case a of {True -> t; _ -> f} ==> if a then t else f warn  "Use if" = case a of {False -> f; _ -> t} ==> if a then t else f-warn  "Redundant if" = (if c then (True, x) else (False, x)) ==> (c, x) where note = "reduces strictness"-warn  "Redundant if" = (if c then (False, x) else (True, x)) ==> (not c, x) where note = "reduces strictness"-warn = or [x,y]  ==> x || y-warn = or [x,y,z]  ==> x || y || z-warn = and [x,y]  ==> x && y-warn = and [x,y,z]  ==> x && y && z+warn  "Redundant if" = (if c then (True, x) else (False, x)) ==> (c, x) where note = IncreasesLaziness+warn  "Redundant if" = (if c then (False, x) else (True, x)) ==> (not c, x) where note = IncreasesLaziness+warn = or [x, y] ==> x || y+warn = or [x, y, z] ==> x || y || z+warn = and [x, y] ==> x && y+warn = and [x, y, z] ==> x && y && z error "Redundant if" = (if x then False else y) ==> not x && y where _ = notEq y True error "Redundant if" = (if x then y else True) ==> not x || y where _ = notEq y False error "Redundant not" = not (not x) ==> x-error "Too strict if" = (if c then f x else f y) ==> f (if c then x else y) where note = "reduces strictness"+error "Too strict if" = (if c then f x else f y) ==> f (if c then x else y) where note = IncreasesLaziness  -- ARROW @@ -208,7 +231,7 @@ warn  = (\(x,y) -> (f x,y)) ==> Control.Arrow.first f where _ = notIn [x,y] f warn  = (\(x,y) -> (x,f y)) ==> Control.Arrow.second f where _ = notIn [x,y] f warn  = (f (fst x), g (snd x)) ==> (f Control.Arrow.*** g) x-warn "Redundant pair" = (fst x, snd x) ==>  x+warn "Redundant pair" = (fst x, snd x) ==>  x where note = DecreasesLaziness  -- FUNCTOR @@ -244,7 +267,11 @@ warn = liftM2 id ==> ap error = mapM (uncurry f) (zip l m) ==> zipWithM f l m +-- STATE MONAD +error = fst (runState x y) ==> evalState x y+error = snd (runState x y) ==> execState x y+ -- MONAD LIST  error = liftM unzip (mapM f x) ==> Control.Monad.mapAndUnzipM f x@@ -311,7 +338,7 @@ warn = [x | Just x <- a] ==> Data.Maybe.catMaybes a warn = (case m of Nothing -> Nothing; Just x -> x) ==> Control.Monad.join m warn = maybe Nothing id ==> join-warn "Too strict maybe" = maybe (f x) (f . g) ==> f . maybe x g where note = "increases laziness"+warn "Too strict maybe" = maybe (f x) (f . g) ==> f . maybe x g where note = IncreasesLaziness  -- EITHER @@ -353,7 +380,6 @@  -- 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 handle ==> Control.Exception.catch warn = flip (catchJust p) ==> handleJust p@@ -401,8 +427,8 @@ error "Evaluate" = scanr f z [] ==> [z] error "Evaluate" = scanr1 f [] ==> [] error "Evaluate" = scanr1 f [x] ==> [x]-error "Evaluate" = take n [] ==> []-error "Evaluate" = drop n [] ==> []+error "Evaluate" = take n [] ==> [] where note = IncreasesLaziness+error "Evaluate" = drop n [] ==> [] where note = IncreasesLaziness error "Evaluate" = takeWhile p [] ==> [] error "Evaluate" = dropWhile p [] ==> [] error "Evaluate" = span p [] ==> ([],[])@@ -419,8 +445,9 @@  -- COMPLEX -error "Use isPrefixOf" = (take i s == t) ==> _eval_ ((i == length t) && (t `Data.List.isPrefixOf` s))-    where _ = (isList t || isLit t) && isLit i+error "Use isPrefixOf" = take (length t) s == t ==> t `Data.List.isPrefixOf` s+error "Use isPrefixOf" = (take i s == t) ==> _eval_ ((i >= length t) && (t `Data.List.isPrefixOf` s))+    where _ = (isList t || isLit t) && isPos i  {- -- clever hint, but not actually a good idea@@ -502,7 +529,6 @@ 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 main = do f; putStrLn $ show x -- print x@@ -514,6 +540,16 @@ test = \ a -> f a >>= \ b -> return (a, b) fooer input = catMaybes . map Just $ input -- mapMaybe Just main = print $ map (\_->5) [2,3,5] -- const 5+main = x == a || x == b || x == c -- x `elem` [a,b,c]+main = head $ drop n x+main = head $ drop (-3) x -- x+main = head $ drop 2 x -- x !! 2+main = drop 0 x -- x+main = take 0 x -- []+main = take (-5) x -- []+main = take (-y) x+main = take 4 x+main = let (first, rest) = (takeWhile p l, dropWhile p l) in rest -- span p l  import Prelude \ yes = flip mapM -- Control.Monad.forM
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.6 build-type:         Simple name:               hlint-version:            1.8.40+version:            1.8.41 license:            BSD3 license-file:       LICENSE category:           Development@@ -55,6 +55,7 @@         Idea         Settings         Report+        Proof         Test         Util         Parallel
hlint.htm view
@@ -236,6 +236,17 @@ 	HLint does not use the default set of hints if custom hints are specified on the command line using <tt>--with</tt> or <tt>--hint</tt>. To include the default hints either pass <tt>--hint=HLint</tt> on the command line, or add <tt>import "hint" HLint.HLint</tt> in one of the hint files you specify with <tt>--hint</tt>. </p> +<h3>Why do I sometimes get a "Note" with my hint?</h3>++<p>+	Most hints are perfect substitutions, and these are displayed without any notes. However, some hints change the semantics of your program - typically in irrelevant ways - but HLint shows a warning note. HLint does not warn when assuming typeclass laws (such as <tt>==</tt> being symmetric). Some notes you may see include:+</p>+<ul>+	<li><b>Increases laziness</b> - for example <tt>foldl (&&) True</tt> suggests <tt>and</tt> including this note. The new code will work on infinite lists, while the old code would not. Increasing laziness is usually a good idea.</li>+	<li><b>Decreases laziness</b> - for example <tt>(fst a, snd a)</tt> suggests <tt>a</tt> including this note. On evaluation the new code will raise an error if <tt>a</tt> is an error, while the old code would produce a pair containing two error values. Only a small number of hints decrease laziness, and anyone relying on the laziness of the original code would be advised to include a comment.</li>+	<li><b>Removes error</b> - for example <tt>foldr1 (&&)</tt> suggests <tt>and</tt> including the note "Removes error on []". The new code will produce <tt>True</tt> on the empty list, while the old code would raise an error. Unless you are relying on the exception thrown by the empty list, this hint is safe - and if you do rely on the exception, you would be advised to add a comment.+</ul>+ <h2 id="customization">Customizing the hints</h2>  <p>
src/CmdLine.hs view
@@ -42,6 +42,7 @@     ,cmdLanguage :: [Extension]      -- ^ the extensions (may be prefixed by "No")     ,cmdQuiet :: Bool                -- ^ supress all console output     ,cmdCross :: Bool                -- ^ work between source files, applies to hints such as duplicate code between modules+    ,cmdProof :: [FilePath]          -- ^ a proof script to check against     }  @@ -63,6 +64,7 @@           | Encoding String           | FindHints FilePath           | Language String+          | Proof FilePath           | Quiet           | Cross           | Ansi@@ -87,6 +89,7 @@        ,Option "d" ["datadir"] (ReqArg DataDir "dir") "Override the data directory"        ,Option "p" ["path"] (ReqArg Path "dir") "Directory in which to search for files"        ,Option "q" ["quiet"] (NoArg Quiet) "Supress most console output"+       ,Option ""  ["proof"] (ReqArg Proof "file") "Isabelle/HOLCF theory file"        ,Option ""  ["cpp-define"] (ReqArg Define "name[=value]") "CPP #define"        ,Option ""  ["cpp-include"] (ReqArg Include "dir") "CPP include path"        ,Option ""  ["cpp-simple"] (NoArg SimpleCpp) "Use a simple CPP (strip # lines)"@@ -152,6 +155,7 @@         ,cmdLanguage = languages         ,cmdQuiet = Quiet `elem` opt         ,cmdCross = Cross `elem` opt+        ,cmdProof = [x | Proof x <- opt]         }
src/HLint.hs view
@@ -12,6 +12,7 @@ import Idea import Apply import Test+import Proof import Util import Parallel import HSE.All@@ -49,6 +50,11 @@     let flags = parseFlags{cppFlags=cmdCpp, encoding=cmdEncoding, language=cmdLanguage}     if cmdTest then         test (\x -> hlint x >> return ()) cmdDataDir cmdGivenHints >> return []+     else if notNull cmdProof then do+        s <- readAllSettings cmd flags+        let reps = if cmdReports == ["report.html"] then ["report.txt"] else cmdReports+        mapM_ (proof reps s) cmdProof+        return []      else if isNothing cmdFiles && notNull cmdFindHints then         mapM_ (\x -> putStrLn . fst =<< findSettings flags x) cmdFindHints >> return []      else if isNothing cmdFiles then@@ -58,14 +64,18 @@      else         runHints cmd flags --runHints :: Cmd -> ParseFlags -> IO [Suggestion]-runHints Cmd{..} flags = do-    let outStrLn x = unless cmdQuiet $ putStrLn x+readAllSettings :: Cmd -> ParseFlags -> IO [Setting]+readAllSettings Cmd{..} flags = do     settings1 <- readSettings cmdDataDir cmdHintFiles cmdWithHints     settings2 <- concatMapM (fmap snd . findSettings flags) cmdFindHints     settings3 <- return [Classify Ignore x ("","") | x <- cmdIgnore]-    let settings = settings1 ++ settings2 ++ settings3+    return $ settings1 ++ settings2 ++ settings3+++runHints :: Cmd -> ParseFlags -> IO [Suggestion]+runHints cmd@Cmd{..} flags = do+    let outStrLn x = unless cmdQuiet $ putStrLn x+    settings <- readAllSettings cmd flags      let files = fromMaybe [] cmdFiles     ideas <- if cmdCross
src/HSE/Bracket.hs view
@@ -45,6 +45,7 @@         | isAtom child = False         | InfixApp{} <- parent, App{} <- child = False         | isSection parent, App{} <- child = False+        | Let{} <- parent, App{} <- child = False         | ListComp{} <- parent = False         | List{} <- parent = False         | Tuple{} <- parent = False
src/HSE/Evaluate.hs view
@@ -19,6 +19,8 @@ evaluate1 (App s len (List _ xs)) | len ~= "length" = Lit s $ Int s n (show n)     where n = fromIntegral $ length xs evaluate1 (view -> App2 op (Lit _ x) (Lit _ y)) | op ~= "==" = toNamed $ show $ x =~= y+evaluate1 (view -> App2 op (Lit _ (Int _ x _)) (Lit _ (Int _ y _)))+    | op ~= ">=" = toNamed $ show $ x >= y evaluate1 (view -> App2 op x y)     | op ~= "&&" && x ~= "True"  = y     | op ~= "&&" && x ~= "False" = x
src/HSE/Util.hs view
@@ -75,6 +75,7 @@ isList List{} = True; isList _ = False isAnyApp x = isApp x || isInfixApp x isParen Paren{} = True; isParen _ = False+isIf If{} = True; isIf _ = False isLambda Lambda{} = True; isLambda _ = False isMDo MDo{} = True; isMDo _ = False isBoxed Boxed{} = True; isBoxed _ = False
src/Hint/Duplicate.hs view
@@ -36,7 +36,7 @@         (if length xs >= 5 then Error else Warning)         "Reduce duplication" p1         (unlines $ map (prettyPrint . fmap (const p1)) xs)-        ("Combine with " ++ showSrcLoc p2) ""+        ("Combine with " ++ showSrcLoc p2) []     | (p1,p2,xs) <- duplicateOrdered 3 $ map (map (toSrcLoc . ann &&& dropAnn)) ys]
src/Hint/Extensions.hs view
@@ -63,8 +63,8 @@   -- 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 _ _ = ""+warnings old new | RecordWildCards `elem` old && RecordWildCards `notElem` new = [Note "you may need to add DisambiguateRecordFields"]+warnings _ _ = []   used :: Extension -> Module_ -> Bool
src/Hint/Import.hs view
@@ -56,7 +56,7 @@   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 @@ -124,7 +124,7 @@     = [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 _ = []@@ -141,7 +141,7 @@     [ 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]
src/Hint/Match.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards, ViewPatterns, RelaxedPolyRec #-}+{-# LANGUAGE PatternGuards, ViewPatterns, RelaxedPolyRec, RecordWildCards #-}  {- The matching does a fairly simple unification between the two terms, treating@@ -83,8 +83,8 @@   , m <- matches, Just (y,notes) <- [matchIdea s decl m parent x2]]  -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+matchIdea :: Scope -> Decl_ -> Setting -> Maybe (Int, Exp_) -> Exp_ -> Maybe (Exp_,[Note])+matchIdea s decl MatchExp{..} parent x = do     let nm = nameMatch scope s     u <- unifyExp nm True lhs x     u <- check u@@ -186,8 +186,18 @@          isType "Atom" x = isAtom x         isType "WHNF" x = isWHNF x+        isType "Nat" (asInt -> Just x) | x >= 0 = True+        isType "Pos" (asInt -> Just x) | x >  0 = True+        isType "Neg" (asInt -> Just x) | x <  0 = True+        isType "NegZero" (asInt -> Just x) | x <= 0 = True         isType ('L':'i':'t':typ@(_:_)) (Lit _ x) = head (words $ show x) == typ         isType typ x = head (words $ show x) == typ++        asInt :: Exp_ -> Maybe Integer+        asInt (Paren _ x) = asInt x+        asInt (NegApp _ x) = fmap negate $ asInt x+        asInt (Lit _ (Int _ x _)) = Just x+        asInt _ = Nothing          list :: Exp_ -> [Exp_]         list (List _ xs) = 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
@@ -1,6 +1,6 @@ {-# LANGUAGE RecordWildCards, NoMonomorphismRestriction #-} -module Idea(module Idea, Severity(..)) where+module Idea(module Idea, Note(..), showNotes, Severity(..)) where  import HSE.All import Settings@@ -10,7 +10,7 @@   data Idea-    = Idea {func :: FuncName, severity :: Severity, hint :: String, loc :: SrcLoc, from :: String, to :: String, note :: String}+    = Idea {func :: FuncName, severity :: Severity, hint :: String, loc :: SrcLoc, from :: String, to :: String, note :: [Note]}     | ParseError {severity :: Severity, hint :: String, loc :: SrcLoc, msg :: String, from :: String}       deriving (Eq,Ord) @@ -31,7 +31,7 @@ showEx tt Idea{..} = unlines $     [showSrcLoc loc ++ ": " ++ show severity ++ ": " ++ hint] ++     f "Found" from ++ f "Why not" to ++-    ["Note: " ++ note | note /= ""]+    ["Note: " ++ n | let n = showNotes note, n /= ""]     where         f msg x | null xs = [msg ++ " remove it."]                 | otherwise = (msg ++ ":") : map ("  "++) xs@@ -42,7 +42,7 @@   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/Proof.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE RecordWildCards, PatternGuards #-}++module Proof(proof) where++import Control.Arrow+import Control.Monad+import Control.Monad.Trans.State+import Data.Char+import Data.List+import Data.Maybe+import Data.Function+import System.FilePath+import Settings+import HSE.All+++data Theorem = Theorem+    {original :: Maybe Setting+    ,location :: String+    ,lemma :: String+    }++instance Eq Theorem where+    t1 == t2 = lemma t1 == lemma t2++instance Show Theorem where+    show Theorem{..} = location ++ ":\n" ++ maybe "" f original ++ lemma ++ "\n"+        where f MatchExp{..} = "(* " ++ prettyPrint lhs ++ " ==> " ++ prettyPrint rhs ++ " *)\n"++proof :: [FilePath] -> [Setting] -> FilePath -> IO ()+proof reports hints thy = do+    got <- fmap (isabelleTheorems (takeFileName thy)) $ readFile thy+    let want = nub $ hintTheorems hints+    let unused = got \\ want+    let missing = want \\ got+    let reasons = map (\x -> (fst $ head x, map snd x)) $ groupBy ((==) `on` fst) $+                  sortBy (compare `on` fst) $ map (classifyMissing &&& id) missing+    let summary = table $ let (*) = (,) in+            ["HLint hints" * want+            ,"HOL proofs" * got+            ,"Useful proofs" * (got `intersect` want)+            ,"Unused proofs" * unused+            ,"Unproved hints" * missing] +++            [("  " ++ name) * ps | (name,ps) <- reasons]+    putStr $ unlines summary+    forM_ reports $ \report -> do+        let out = ("Unused proofs",unused) : map (first ("Unproved hints - " ++)) reasons+        writeFile report $ unlines $ summary ++ "" : concat+            [("== " ++ a ++ " ==") : "" : map show b | (a,b) <- out]+        putStrLn $ "Report written to " ++ report+    where+        table xs = [a ++ replicate (n + 6 - length a - length bb) ' ' ++ bb | (a,b) <- xs, let bb = show $ length b]+            where n = maximum $ map (length . fst) xs+++missingFuncs = let a*b = [(b,a) | b <- words b] in concat+    ["IO" * "putChar putStr print putStrLn getLine getChar getContents hReady hPrint stdin"+    ,"Exit" * "exitSuccess"+    ,"Ord" * "(>) (<=) (>=) (<) compare minimum maximum sort sortBy"+    ,"Show" * "show shows showIntAtBase"+    ,"Read" * "reads read"+    ,"String" * "lines unlines words unwords"+    ,"Monad" * "mapM mapM_ sequence sequence_ msum mplus mzero liftM when unless return evaluate join void (>>=) (<=<) (>=>) forever ap"+    ,"Functor" * "fmap"+    ,"Numeric" * "(+) (*) fromInteger fromIntegral negate log (/) (-) (*) (^^) (^) subtract sqrt even odd"+    ,"Char" * "isControl isPrint isUpper isLower isAlpha isDigit"+    ,"Arrow" * "second first (***) (&&&)"+    ,"Applicative+" * "traverse for traverse_ for_ pure (<|>) (<**>)"+    ,"Exception" * "catch handle catchJust bracket error toException"+    ,"WeakPtr" * "mkWeak"+    ]+++-- | Guess why a theorem is missing+classifyMissing :: Theorem -> String+classifyMissing Theorem{original = Just MatchExp{..}}+    | _:_ <- [v :: Exp_ | v@Case{} <- universeBi (lhs,rhs)] = "case"+    | _:_ <- [v :: Exp_ | v@ListComp{} <- universeBi (lhs,rhs)] = "list-comp"+    | v:_ <- mapMaybe (`lookup` missingFuncs) [prettyPrint (v :: Name SrcSpanInfo) | v <- universeBi (lhs,rhs)] = v+classifyMissing _ = "?unknown"+++-- Extract theorems out of Isabelle code (HLint.thy)+isabelleTheorems :: FilePath -> String -> [Theorem]+isabelleTheorems file = find . lexer 1+    where+        find ((i,"lemma"):(_,'\"':lemma):rest) = Theorem Nothing (file ++ ":" ++ show i) lemma : find rest+        find ((i,"lemma"):(_,name):(_,":"):(_,'\"':lemma):rest) = Theorem Nothing (file ++ ":" ++ show i) lemma : find rest+        find ((i,"lemma"):(_,"assumes"):(_,'\"':assumes):(_,"shows"):(_,'\"':lemma):rest) =+            Theorem Nothing (file ++ ":" ++ show i) (assumes ++ " \\<Longrightarrow> " ++ lemma) : find rest++        find ((i,"lemma"):rest) = Theorem Nothing (file ++ ":" ++ show i) "Unsupported lemma format" : find rest+        find (x:xs) = find xs+        find [] = []++        lexer i x+            | i `seq` False = []+            | Just x <- stripPrefix "(*" x, (a,b) <- breaks "*)" x = lexer (add a i) b+            | Just x <- stripPrefix "\"" x, (a,b) <- breaks "\"" x = (i,'\"':a) : lexer (add a i) b -- NOTE: drop the final "+            | x:xs <- x, isSpace x = lexer (add [x] i) xs+            | (a@(_:_),b) <- span (\y -> y == '_' || isAlpha y) x = (i,a) : lexer (add a i) b+        lexer i (x:xs) = (i,[x]) : lexer (add [x] i) xs+        lexer i [] = []++        add s i = length (filter (== '\n') s) + i++        breaks s x | Just x <- stripPrefix s x = ("",x)+        breaks s (x:xs) = let (a,b) = breaks s xs in (x:a,b)+        breaks s [] = ([],[])+++reparen :: Setting -> Setting+reparen m@MatchExp{..} = m{lhs = f False lhs, rhs = f True rhs}+    where f right x = if isLambda x || isIf x || badInfix x then Paren (ann x) x else x+          badInfix (InfixApp _ _ op _) = prettyPrint op `elem` words "|| && ."+          badInfix _ = False+reparen x = x+++-- Extract theorems out of the hints+hintTheorems :: [Setting] -> [Theorem]+hintTheorems xs =+    [ Theorem (Just m) (loc $ ann lhs) $ maybe "" assumes side ++ relationship notes a b+    | m@MatchExp{..} <- map reparen xs, let a = exp1 $ typeclasses notes lhs, let b = exp1 rhs, a /= b]+    where+        loc (SrcSpanInfo (SrcSpan file ln _ _ _) _) = takeFileName file ++ ":" ++ show ln++        subs xs = flip lookup [(reverse b, reverse a) | x <- words xs, let (a,'=':b) = break (== '=') $ reverse x]+        funs = subs "id=ID not=neg or=the_or and=the_and (||)=tror (&&)=trand (++)=append (==)=eq (/=)=neq ($)=dollar"+        ops = subs "||=orelse &&=andalso .=oo ===eq /==neq ++=++ !!=!! $=dollar $!=dollarBang"+        pre = flip elem $ words "eq neq dollar dollarBang"+        cons = subs "True=TT False=FF"++        typeclasses notes x = foldr f x notes+            where+                f (ValidInstance cls var) x = evalState (transformM g x) True+                    where g v@Var{} | v ~= var = do+                                b <- get; put False+                                return $ if b then Paren an $ toNamed $ prettyPrint v ++ "::'a::" ++ cls ++ "_sym" else v+                          g v = return v :: State Bool Exp_+                f _  x = x++        relationship notes a b | any lazier notes = a ++ " \\<sqsubseteq> " ++ b+                               | DecreasesLaziness `elem` notes = b ++ " \\<sqsubseteq> " ++ a+                               | otherwise = a ++ " = " ++ b+            where lazier IncreasesLaziness = True+                  lazier RemovesError{} = True+                  lazier _ = False++        assumes (App _ op var)+            | op ~= "isNat" = "le\\<cdot>0\\<cdot>" ++ prettyPrint var ++ " \\<noteq> FF \\<Longrightarrow> "+            | op ~= "isNegZero" = "gt\\<cdot>0\\<cdot>" ++ prettyPrint var ++ " \\<noteq> FF \\<Longrightarrow> "+        assumes (App _ op var) | op ~= "isWHNF" = prettyPrint var ++ " \\<noteq> \\<bottom> \\<Longrightarrow> "+        assumes _ = ""++        exp1 = exp . transformBi unqual++        -- Syntax translations+        exp (App _ a b) = exp a ++ "\\<cdot>" ++ exp b+        exp (Paren _ x) = "(" ++ exp x ++ ")"+        exp (Var _ x) | Just x <- funs $ prettyPrint x = x+        exp (Con _ (Special _ (TupleCon _ _ i))) = "\\<langle>" ++ replicate (i-1) ',' ++ "\\<rangle>"+        exp (Con _ x) | Just x <- cons $ prettyPrint x = x+        exp (Tuple _ xs) = "\\<langle>" ++ intercalate ", " (map exp xs) ++ "\\<rangle>"+        exp (If _ a b c) = "If " ++ exp a ++ " then " ++ exp b ++ " else " ++ exp c+        exp (Lambda _ xs y) = "\\<Lambda> " ++ unwords (map pat xs) ++ ". " ++ exp y+        exp (InfixApp _ x op y) | Just op <- ops $ prettyPrint op =+            if pre op then op ++ "\\<cdot>" ++ exp (paren x) ++ "\\<cdot>" ++ exp (paren y) else exp x ++ " " ++ op ++ " " ++ exp y++        -- Translations from the Haskell 2010 report+        exp (InfixApp l a (QVarOp _ b) c) = exp $ App l (App l (Var l b) a) c -- S3.4+        exp x@(LeftSection l e op) = let v = fresh x in exp $ Paren l $ Lambda l [toNamed v] $ InfixApp l e op (toNamed v) -- S3.5+        exp x@(RightSection l op e) = let v = fresh x in exp $ Paren l $ Lambda l [toNamed v] $ InfixApp l (toNamed v) op e -- S3.5+        exp x = prettyPrint x++        pat (PTuple _ xs) = "\\<langle>" ++ intercalate ", " (map pat xs) ++ "\\<rangle>"+        pat x = prettyPrint x++        fresh x = head $ ("z":["v" ++ show i | i <- [1..]]) \\ vars x
src/Report.hs view
@@ -56,7 +56,7 @@     ,code from     ,"Why not" ++ (if to == "" then " remove it." else "") ++ "<br/>"     ,code to-    ,if note /= "" then "<span class='note'>Note: " ++ note ++ "</span>" else ""+    ,let n = showNotes note in if n /= "" then "<span class='note'>Note: " ++ n ++ "</span>" else ""     ,"</div>"     ,""]
src/Settings.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE PatternGuards, ViewPatterns #-}  module Settings(-    Severity(..), FuncName, Setting(..), isClassify, isMatchExp,+    Severity(..), Note(..), showNotes, FuncName, Setting(..), isClassify, isMatchExp,     defaultHintName, isUnifyVar,     readSettings, readPragma, findSettings     ) where@@ -48,9 +48,31 @@ --------------------------------------------------------------------- -- TYPE +data Note+    = IncreasesLaziness+    | DecreasesLaziness+    | RemovesError String -- RemovesError "on []", RemovesError "when x is negative"+    | ValidInstance String String -- ValidInstance "Eq" "x"+    | Note String+      deriving (Eq,Ord)++instance Show Note where+    show IncreasesLaziness = "increases laziness"+    show DecreasesLaziness = "decreases laziness"+    show (RemovesError x) = "removes error " ++ x+    show (ValidInstance x y) = "requires a valid " ++ x ++ " instance for " ++ y+    show (Note x) = x+++showNotes :: [Note] -> String+showNotes = intercalate ", " . map show . filter use+    where use ValidInstance{} = False -- Not important enough to tell an end user+          use _ = True++ data Setting     = Classify {severityS :: Severity, hintS :: String, funcS :: FuncName}-    | MatchExp {severityS :: Severity, hintS :: String, scope :: Scope, lhs :: Exp_, rhs :: Exp_, side :: Maybe Exp_, notes :: String}+    | MatchExp {severityS :: Severity, hintS :: String, scope :: Scope, lhs :: Exp_, rhs :: Exp_, side :: Maybe Exp_, notes :: [Note]}     | Builtin String -- use a builtin hint set     | Infix Fixity       deriving Show@@ -122,11 +144,25 @@ readPragma _ = Nothing  -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)+readSide :: [Decl_] -> (Maybe Exp_, [Note])+readSide = foldl f (Nothing,[])+    where f (Nothing,notes) (PatBind _ PWildCard{} Nothing (UnGuardedRhs _ side) Nothing) = (Just side, notes)+          f (side,[]) (PatBind _ (fromNamed -> "note") Nothing (UnGuardedRhs _ note) Nothing) = (side,g note)           f _ x = errorOn x "bad side condition"++          g (Lit _ (String _ x _)) = [Note x]+          g (List _ xs) = concatMap g xs+          g x = case fromApps x of+              [con -> Just "IncreasesLaziness"] -> [IncreasesLaziness]+              [con -> Just "DecreasesLaziness"] -> [DecreasesLaziness]+              [con -> Just "RemovesError",str -> Just a] -> [RemovesError a]+              [con -> Just "ValidInstance",str -> Just a,var -> Just b] -> [ValidInstance a b]+              _ -> errorOn x "bad note"++          con :: Exp_ -> Maybe String+          con c@Con{} = Just $ prettyPrint c; con _ = Nothing+          var c@Var{} = Just $ prettyPrint c; var _ = Nothing+          str c = if isString c then Just $ fromString c else Nothing   -- Note: Foo may be ("","Foo") or ("Foo",""), return both
src/Test.hs view
@@ -107,9 +107,14 @@     where         matches = filter isMatchExp hints +        -- Hack around haskell98 not being compatible with base anymore+        hackImport i@ImportDecl{importAs=Just a,importModule=b}+            | prettyPrint b `elem` words "Maybe List Monad IO Char" = i{importAs=Just b,importModule=a}+        hackImport i = i+         contents =             ["{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules #-}"] ++-            concat (take 1 [map prettyPrint $ scopeImports $ scope x | x <- matches]) +++            concat [map (prettyPrint . hackImport) $ scopeImports $ scope x | x <- take 1 matches] ++             ["main = return ()"             ,"(==>) :: a -> a -> a; (==>) = undefined"             ,"_noParen_ = id"