diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,24 @@ Changelog for HLint +1.9.27 + #203, avoid recompiling everything twice + #213, don't suggest removing bang patterns on let + Rename HintStructure to HintPattern + #208, add an hlint function to the HLint3 API + #1, warn about unused DefaultSignatures extension + #137, add -XHaskell2010 and fix -XHaskell98 + Allow checking even if a function has different arities + #193, don't warn on a -> (b -> c), it's sometimes sensible + #182, make parse errors severity Error + #181, warn on otherwise in a pattern variable + #163, eta reduce fun x = f $ x + #132, don't ever suggest liftM + #99, downgrade built in hints, Error => Warning => Suggestion + #99, add a Suggestion level severity + #207, make sure you close file handles + #205, add hint compare x y == EQ and /= + #204, add hint concatMap id ==> concat + #202, include refactorings is --json output 1.9.26 #200, fix all lint warnings #143, expose argsSettings diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,5 @@ # HLint [![Hackage version](https://img.shields.io/hackage/v/hlint.svg?label=Hackage)](https://hackage.haskell.org/package/hlint) [![Stackage version](https://www.stackage.org/package/hlint/badge/lts?label=Stackage)](https://www.stackage.org/package/hlint) [![Linux Build Status](https://img.shields.io/travis/ndmitchell/hlint.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/hlint) [![Windows Build Status](https://img.shields.io/appveyor/ci/ndmitchell/hlint.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/hlint) - HLint is a tool for suggesting possible improvements to Haskell code. These suggestions include ideas such as using alternative functions, simplifying code and spotting redundancies. You can try HLint online at [lpaste.net](http://lpaste.net/) - suggestions are shown at the bottom. This document is structured as follows: * [Installing and running HLint](#installing-and-running-hlint) @@ -30,29 +29,29 @@ $ hlint darcs-2.1.2 - darcs-2.1.2\src\CommandLine.lhs:94:1: Error: Use concatMap + darcs-2.1.2\src\CommandLine.lhs:94:1: Warning: Use concatMap Found: concat $ map escapeC s Why not: concatMap escapeC s - darcs-2.1.2\src\CommandLine.lhs:103:1: Warning: Use fewer brackets + darcs-2.1.2\src\CommandLine.lhs:103:1: Suggestion: Use fewer brackets Found: ftable ++ (map (\ (c, x) -> (toUpper c, urlEncode x)) ftable) Why not: ftable ++ map (\ (c, x) -> (toUpper c, urlEncode x)) ftable - darcs-2.1.2\src\Darcs\Patch\Test.lhs:306:1: Error: Use a more efficient monadic variant + darcs-2.1.2\src\Darcs\Patch\Test.lhs:306:1: Warning: Use a more efficient monadic variant Found: mapM (delete_line (fn2fp f) line) old Why not: mapM_ (delete_line (fn2fp f) line) old - ... lots more suggestions ... + ... lots more hints ... -Each suggestion says which file/line the suggestion relates to, how serious the issue is, a description of the issue, what it found, and what you might want to replace it with. In the case of the first hint, it has suggested that instead of applying `concat` and `map` separately, it would be better to use the combination function `concatMap`. +Each hint says which file/line the hint relates to, how serious an issue it is, a description of the hint, what it found, and what you might want to replace it with. In the case of the first hint, it has suggested that instead of applying `concat` and `map` separately, it would be better to use the combination function `concatMap`. -The first suggestion is marked as an error, because using `concatMap` in preference to the two separate functions is always desirable. In contrast, the removal of brackets is probably a good idea, but not always. Reasons that a hint might be a warning include requiring an additional import, something not everyone agrees on, and functions only available in more recent versions of the base library. +The first hint is marked as an warning, because using `concatMap` in preference to the two separate functions is always desirable. In contrast, the removal of brackets is probably a good idea, but not always. Reasons that a hint might be a suggestion include requiring an additional import, something not everyone agrees on, and functions only available in more recent versions of the base library. **Bug reports:** The suggested replacement should be equivalent - please report all incorrect suggestions not mentioned as known limitations. @@ -89,7 +88,7 @@ ### Emacs Integration -Emacs integration has been provided by [Alex Ott](http://xtalk.msk.su/~ott/). The integration is similar to compilation-mode, allowing navigation between errors. The script is at [hs-lint.el](https://github.com/ndmitchell/hlint/blob/master/data/hs-lint.el), and a copy is installed locally in the data directory. To use, add the following code to the Emacs init file: +Emacs integration has been provided by [Alex Ott](http://xtalk.msk.su/~ott/). The integration is similar to compilation-mode, allowing navigation between errors. The script is at [hs-lint.el](https://raw.githubusercontent.com/ndmitchell/hlint/master/data/hs-lint.el), and a copy is installed locally in the data directory. To use, add the following code to the Emacs init file: (require 'hs-lint) (defun my-haskell-mode-hook () @@ -98,7 +97,7 @@ ### GHCi Integration -GHCi integration has been provided by Gwern Branwen. The integration allows running `:hlint` from the GHCi prompt. The script is at [hlint.ghci](http://community.haskell.org/~ndm/darcs/hlint/data/hlint.ghci), and a copy is installed locally in the data directory. To use, add the contents to your [GHCi startup file](http://www.haskell.org/ghc/docs/latest/html/users_guide/ghci-dot-files.html). +GHCi integration has been provided by Gwern Branwen. The integration allows running `:hlint` from the GHCi prompt. The script is at [hlint.ghci](https://raw.githubusercontent.com/ndmitchell/hlint/master/data/hlint.ghci), and a copy is installed locally in the data directory. To use, add the contents to your [GHCi startup file](http://www.haskell.org/ghc/docs/latest/html/users_guide/ghci-dot-files.html). ### Parallel Operation @@ -119,7 +118,7 @@ ## FAQ -### Why are suggestions not applied recursively? +### Why are hints not applied recursively? Consider: @@ -152,16 +151,17 @@ * __Increases laziness__ - for example `foldl (&&) True` suggests `and` including this note. The new code will work on infinite lists, while the old code would not. Increasing laziness is usually a good idea. * __Decreases laziness__ - for example `(fst a, snd a)` suggests a including this note. On evaluation the new code will raise an error if a 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. -* __Removes error__ - for example foldr1 (&&) suggests and including the note "Removes error on []". The new code will produce `True` 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. +* __Removes error__ - for example `foldr1 (&&)` suggests and including the note `Removes error on []`. The new code will produce `True` 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. -### What is the difference between error and warning? +### What is the difference between error/warning/suggestion? Every hint has a severity level: -* __Error__ - for example `concat (map f x)` suggests `concatMap f x` as an "error" severity hint. From a style point of view, you should always replace a combination of `concat` and `map` with `concatMap`. Note that both expressions are equivalent - HLint is reporting an error in style, not an actual error in the code. -* __Warning__ - for example `x !! 0` suggests head x as a "warning" severity hint. Typically head is a simpler way of expressing the first element of a list, especially if you are treating the list inductively. However, in the expression `f (x !! 4) (x !! 0) (x !! 7)`, replacing the middle argument with `head` makes it harder to follow the pattern, and is probably a bad idea. Warning hints are often worthwhile, but should not be applied blindly. +* __Error__ - by default only used for parse errors. +* __Warning__ - for example `concat (map f x)` suggests `concatMap f x` as a "warning" severity hint. From a style point of view, you should always replace a combination of `concat` and `map` with `concatMap`. +* __Suggestion__ - for example `x !! 0` suggests `head x` as a "suggestion" severity hint. Typically `head` is a simpler way of expressing the first element of a list, especially if you are treating the list inductively. However, in the expression `f (x !! 4) (x !! 0) (x !! 7)`, replacing the middle argument with `head` makes it harder to follow the pattern, and is probably a bad idea. Suggestion hints are often worthwhile, but should not be applied blindly. -The difference between error and warning is one of personal taste, typically my personal taste. If you already have a well developed sense of Haskell style, you should ignore the difference. If you are a beginner Haskell programmer you may wish to focus on error hints before warning hints. +The difference between warning and suggestion is one of personal taste, typically my personal taste. If you already have a well developed sense of Haskell style, you should ignore the difference. If you are a beginner Haskell programmer you may wish to focus on warning hints before suggestion hints. ## Customizing the hints @@ -187,8 +187,9 @@ * `{-# ANN module "HLint: ignore Eta reduce" #-}` - ignore all eta reduction suggestions in this module (use `module` literally, not the name of the module). * `{-# ANN myFunction "HLint: ignore" #-}` - don't give any hints in the function `myFunction`. * `{-# ANN myFunction "HLint: error" #-}` - any hint in the function `myFunction` is an error. -* `{-# ANN module "HLint: error Use concatMap" #-}` - the hint to use concatMap is an error. -* `{-# ANN module "HLint: warn Use concatMap" #-}` - the hint to use concatMap is a warning. +* `{-# ANN module "HLint: error Use concatMap" #-}` - the hint to use `concatMap` is an error. +* `{-# ANN module "HLint: warn Use concatMap" #-}` - the hint to use `concatMap` is a warning. +* `{-# ANN module "HLint: suggest Use concatMap" #-}` - the hint to use `concatMap` is a suggestion. Ignore directives can also be written in the hint files: @@ -198,6 +199,7 @@ * `error = MyModule.myFunction` - any hint in the function `MyModule.myFunction` is an error. * `error "Use concatMap"` - the hint to use `concatMap` is an error. * `warn "Use concatMap"` - the hint to use `concatMap` is a warning. +* `suggest "Use concatMap"` - the hint to use `concatMap` is a suggestion. These directives are applied in the order they are given, with later hints overriding earlier ones. @@ -205,9 +207,9 @@ The hint suggesting `concatMap` is defined as: - error = concat (map f x) ==> concatMap f x + warn = concat (map f x) ==> concatMap f x -The line can be read as replace `concat (map f x)` with `concatMap f x`. All single-letter variables are treated as substitution parameters. For examples of more complex hints see the supplied hints file. In general, hints should not be given in point free style, as this reduces the power of the matching. Hints may start with `error` or `warn` to denote how severe they are by default. If you come up with interesting hints, please submit them for inclusion. +The line can be read as replace `concat (map f x)` with `concatMap f x`. All single-letter variables are treated as substitution parameters. For examples of more complex hints see the supplied hints file. In general, hints should not be given in point free style, as this reduces the power of the matching. Hints may start with `error`, `warn` or `suggest` to denote how severe they are by default. In addition, `hint` is a synonym for `suggest`. If you come up with interesting hints, please submit them for inclusion. You can search for possible hints to add from a source file with the `--find` flag, for example: diff --git a/data/Default.hs b/data/Default.hs --- a/data/Default.hs +++ b/data/Default.hs @@ -32,492 +32,495 @@ -- I/O -error = putStrLn (show x) ==> print x -error = mapM_ putChar ==> putStr -error = hGetChar stdin ==> getChar -error = hGetLine stdin ==> getLine -error = hGetContents stdin ==> getContents -error = hPutChar stdout ==> putChar -error = hPutStr stdout ==> putStr -error = hPutStrLn stdout ==> putStrLn -error = hPrint stdout ==> print -error = hWaitForInput a 0 ==> hReady a -error = hPutStrLn a (show b) ==> hPrint a b -error = hIsEOF stdin ==> isEOF +warn = putStrLn (show x) ==> print x +warn = mapM_ putChar ==> putStr +warn = hGetChar stdin ==> getChar +warn = hGetLine stdin ==> getLine +warn = hGetContents stdin ==> getContents +warn = hPutChar stdout ==> putChar +warn = hPutStr stdout ==> putStr +warn = hPutStrLn stdout ==> putStrLn +warn = hPrint stdout ==> print +warn = hWaitForInput a 0 ==> hReady a +warn = hPutStrLn a (show b) ==> hPrint a b +warn = hIsEOF stdin ==> isEOF -- EXIT -error = exitWith ExitSuccess ==> exitSuccess +warn = exitWith ExitSuccess ==> exitSuccess -- ORD -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 -error = compare x y == GT ==> x > y +warn = not (a == b) ==> a /= b where note = "incorrect if either value is NaN" +warn = not (a /= b) ==> a == b where note = "incorrect if either value is NaN" +warn = not (a > b) ==> a <= b where note = "incorrect if either value is NaN" +warn = not (a >= b) ==> a < b where note = "incorrect if either value is NaN" +warn = not (a < b) ==> a >= b where note = "incorrect if either value is NaN" +warn = not (a <= b) ==> a > b where note = "incorrect if either value is NaN" +warn = compare x y /= GT ==> x <= y +warn = compare x y == LT ==> x < y +warn = compare x y /= LT ==> x >= y +warn = compare x y == GT ==> x > y +warn = compare x y == EQ ==> x == y +warn = compare x y /= EQ ==> x /= y --warning = x == a || x == b || x == c ==> x `elem` [a,b,c] where note = ValidInstance "Eq" x --warning = 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 -error = last (sort x) ==> maximum x -error = head (sortBy f x) ==> minimumBy f x +--warn = compare (f x) (f y) ==> Data.Ord.comparing f x y -- not that great +--warn = on compare f ==> Data.Ord.comparing f -- not that great +warn = head (sort x) ==> minimum x +warn = last (sort x) ==> maximum x +warn = head (sortBy f x) ==> minimumBy f x where _ = isCompare f -error = last (sortBy f x) ==> maximumBy f x +warn = last (sortBy f x) ==> maximumBy f x where _ = isCompare f -error "Avoid reverse" = reverse (sort x) ==> sortBy (flip compare) x -error "Avoid reverse" = reverse (sortBy f x) ==> sortBy (flip f) x +warn "Avoid reverse" = reverse (sort x) ==> sortBy (flip compare) x +warn "Avoid reverse" = reverse (sortBy f x) ==> sortBy (flip f) x where _ = isCompare f -warn = flip (g `on` h) ==> flip g `on` h -warn = (f `on` g) `on` h ==> f `on` (g . h) +hint = flip (g `on` h) ==> flip g `on` h +hint = (f `on` g) `on` h ==> f `on` (g . h) -- READ/SHOW -error = showsPrec 0 x "" ==> show x -error = readsPrec 0 ==> reads -error = showsPrec 0 ==> shows -warn = showIntAtBase 16 intToDigit ==> showHex -warn = showIntAtBase 8 intToDigit ==> showOct +warn = showsPrec 0 x "" ==> show x +warn = readsPrec 0 ==> reads +warn = showsPrec 0 ==> shows +hint = showIntAtBase 16 intToDigit ==> showHex +hint = showIntAtBase 8 intToDigit ==> showOct -- LIST -error = concat (map f x) ==> concatMap f x -error = concat (fmap f x) ==> concatMap f x -warn = concat [a, b] ==> a ++ b -warn "Use map once" = map f (map g x) ==> map (f . g) x -warn "Fuse concatMap/map" = concatMap f (map g x) ==> concatMap (f . g) x -warn = x !! 0 ==> head x -error = take n (repeat x) ==> replicate n x +warn = concat (map f x) ==> concatMap f x +warn = concat (fmap f x) ==> concatMap f x +hint = concat [a, b] ==> a ++ b +hint "Use map once" = map f (map g x) ==> map (f . g) x +hint "Fuse concatMap/map" = concatMap f (map g x) ==> concatMap (f . g) x +hint = x !! 0 ==> head x +warn = take n (repeat x) ==> replicate n x where _ = noQuickCheck -- takes too long -error = map f (replicate n x) ==> replicate n (f x) +warn = map f (replicate n x) ==> replicate n (f x) where _ = noQuickCheck -- takes too long -error = map f (repeat x) ==> repeat (f x) +warn = map f (repeat x) ==> repeat (f x) where _ = noQuickCheck -- takes forever -error = cycle [x] ==> repeat x +warn = cycle [x] ==> repeat x where _ = noQuickCheck -- takes forever -error = head (reverse x) ==> last x -error = head (drop n x) ==> x !! n where _ = isNat n -error = reverse (tail (reverse x)) ==> init x where note = IncreasesLaziness -error "Avoid reverse" = reverse (reverse x) ==> 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 = foldr (++) "" ==> concat -error = foldl (++) [] ==> concat where note = IncreasesLaziness -error = foldl (++) "" ==> concat where note = IncreasesLaziness -error = foldl f (head x) (tail x) ==> foldl1 f x -error = foldr f (last x) (init x) ==> foldr1 f x -error = span (not . p) ==> break p -error = break (not . p) ==> span p -error = (takeWhile p x, dropWhile p x) ==> span p x -error = fst (span p x) ==> takeWhile p x -error = snd (span p x) ==> dropWhile p x -error = fst (break p x) ==> takeWhile (not . p) x -error = snd (break p x) ==> dropWhile (not . p) x -error = concatMap (++ "\n") ==> unlines -error = map id ==> id -error = or (map p x) ==> any p x -error = and (map p x) ==> all p x -error = zipWith (,) ==> zip -error = zipWith3 (,,) ==> zip3 -warn = length x == 0 ==> null x where note = IncreasesLaziness -warn = x == [] ==> null x -warn "Use null" = length x /= 0 ==> not (null x) where note = IncreasesLaziness -warn "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 -error = not (elem x y) ==> notElem x y -warn = foldr f z (map g x) ==> foldr (f . g) z x -error = x ++ concatMap (' ':) y ==> unwords (x:y) -error = intercalate " " ==> unwords -warn = concat (intersperse x y) ==> intercalate x y where _ = notEq x " " -warn = concat (intersperse " " x) ==> unwords x -error "Use any" = null (filter f x) ==> not (any f x) -error "Use any" = filter f x == [] ==> not (any f x) -error = filter f x /= [] ==> any f x -error = any id ==> or -error = all id ==> and -error = any ((==) a) ==> elem a where note = ValidInstance "Eq" a -error = any (== a) ==> elem 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 -error = findIndex (a ==) ==> elemIndex a -error = findIndex (== a) ==> elemIndex a -error = findIndices ((==) a) ==> elemIndices a -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 = 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 = last (scanl f z x) ==> foldl f z x -error = head (scanr f z x) ==> foldr f z x -error = iterate id ==> repeat +warn = head (reverse x) ==> last x +warn = head (drop n x) ==> x !! n where _ = isNat n +warn = reverse (tail (reverse x)) ==> init x where note = IncreasesLaziness +warn "Avoid reverse" = reverse (reverse x) ==> x where note = IncreasesLaziness +-- warn = take (length x - 1) x ==> init x -- not true for x == [] +warn = isPrefixOf (reverse x) (reverse y) ==> isSuffixOf x y +warn = foldr (++) [] ==> concat +warn = foldr (++) "" ==> concat +warn = foldl (++) [] ==> concat where note = IncreasesLaziness +warn = foldl (++) "" ==> concat where note = IncreasesLaziness +warn = foldl f (head x) (tail x) ==> foldl1 f x +warn = foldr f (last x) (init x) ==> foldr1 f x +warn = span (not . p) ==> break p +warn = break (not . p) ==> span p +warn = (takeWhile p x, dropWhile p x) ==> span p x +warn = fst (span p x) ==> takeWhile p x +warn = snd (span p x) ==> dropWhile p x +warn = fst (break p x) ==> takeWhile (not . p) x +warn = snd (break p x) ==> dropWhile (not . p) x +warn = concatMap (++ "\n") ==> unlines +warn = map id ==> id +warn = concatMap id ==> concat +warn = or (map p x) ==> any p x +warn = and (map p x) ==> all p x +warn = zipWith (,) ==> zip +warn = zipWith3 (,,) ==> zip3 +hint = length x == 0 ==> null x where note = IncreasesLaziness +hint = x == [] ==> null x +hint "Use null" = length x /= 0 ==> not (null x) where note = IncreasesLaziness +hint "Use :" = (\x -> [x]) ==> (:[]) +warn = map (uncurry f) (zip x y) ==> zipWith f x y +hint = map f (zip x y) ==> zipWith (curry f) x y where _ = isVar f +warn = not (elem x y) ==> notElem x y +hint = foldr f z (map g x) ==> foldr (f . g) z x +warn = x ++ concatMap (' ':) y ==> unwords (x:y) +warn = intercalate " " ==> unwords +hint = concat (intersperse x y) ==> intercalate x y where _ = notEq x " " +hint = concat (intersperse " " x) ==> unwords x +warn "Use any" = null (filter f x) ==> not (any f x) +warn "Use any" = filter f x == [] ==> not (any f x) +warn = filter f x /= [] ==> any f x +warn = any id ==> or +warn = all id ==> and +warn = any ((==) a) ==> elem a where note = ValidInstance "Eq" a +warn = any (== a) ==> elem a +warn = any (a ==) ==> elem a where note = ValidInstance "Eq" a +warn = all ((/=) a) ==> notElem a where note = ValidInstance "Eq" a +warn = all (/= a) ==> notElem a where note = ValidInstance "Eq" a +warn = all (a /=) ==> notElem a where note = ValidInstance "Eq" a +warn = elem True ==> or +warn = notElem False ==> and +warn = findIndex ((==) a) ==> elemIndex a +warn = findIndex (a ==) ==> elemIndex a +warn = findIndex (== a) ==> elemIndex a +warn = findIndices ((==) a) ==> elemIndices a +warn = findIndices (a ==) ==> elemIndices a +warn = findIndices (== a) ==> elemIndices a +warn = lookup b (zip l [0..]) ==> elemIndex b l +hint "Length always non-negative" = length x >= 0 ==> True +hint "Use null" = length x > 0 ==> not (null x) where note = IncreasesLaziness +hint "Use null" = length x >= 1 ==> not (null x) where note = IncreasesLaziness +warn "Take on a non-positive" = take i x ==> [] where _ = isNegZero i +warn "Drop on a non-positive" = drop i x ==> x where _ = isNegZero i +warn = last (scanl f z x) ==> foldl f z x +warn = head (scanr f z x) ==> foldr f z x +warn = iterate id ==> repeat where _ = noQuickCheck -- takes forever -error = zipWith f (repeat x) ==> map (f x) -error = zipWith f y (repeat z) ==> map (\x -> f x z) y +warn = zipWith f (repeat x) ==> map (f x) +warn = zipWith f y (repeat z) ==> map (\x -> f x z) y -- BY -error = deleteBy (==) ==> delete -error = groupBy (==) ==> group -error = insertBy compare ==> insert -error = intersectBy (==) ==> intersect -error = maximumBy compare ==> maximum -error = minimumBy compare ==> minimum -error = nubBy (==) ==> nub -error = sortBy compare ==> sort -error = unionBy (==) ==> union +warn = deleteBy (==) ==> delete +warn = groupBy (==) ==> group +warn = insertBy compare ==> insert +warn = intersectBy (==) ==> intersect +warn = maximumBy compare ==> maximum +warn = minimumBy compare ==> minimum +warn = nubBy (==) ==> nub +warn = sortBy compare ==> sort +warn = unionBy (==) ==> union -- FOLDS -error = foldr (>>) (return ()) ==> sequence_ +warn = foldr (>>) (return ()) ==> sequence_ where _ = noQuickCheck -error = foldr (&&) True ==> and -error = foldl (&&) True ==> and where note = IncreasesLaziness -error = foldr1 (&&) ==> and where note = RemovesError "on []"; _ = noQuickCheck -error = foldl1 (&&) ==> and where note = RemovesError "on []" -error = foldr (||) False ==> 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 where note = RemovesError "on []" -error = foldr1 (+) ==> sum where note = RemovesError "on []" -error = foldl (*) 1 ==> product -error = foldr (*) 1 ==> 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 -error = foldr1 min ==> minimum -error = foldr mplus mzero ==> msum +warn = foldr (&&) True ==> and +warn = foldl (&&) True ==> and where note = IncreasesLaziness +warn = foldr1 (&&) ==> and where note = RemovesError "on []"; _ = noQuickCheck +warn = foldl1 (&&) ==> and where note = RemovesError "on []" +warn = foldr (||) False ==> or +warn = foldl (||) False ==> or where note = IncreasesLaziness +warn = foldr1 (||) ==> or where note = RemovesError "on []" +warn = foldl1 (||) ==> or where note = RemovesError "on []" +warn = foldl (+) 0 ==> sum +warn = foldr (+) 0 ==> sum +warn = foldl1 (+) ==> sum where note = RemovesError "on []" +warn = foldr1 (+) ==> sum where note = RemovesError "on []" +warn = foldl (*) 1 ==> product +warn = foldr (*) 1 ==> product +warn = foldl1 (*) ==> product where note = RemovesError "on []" +warn = foldr1 (*) ==> product where note = RemovesError "on []" +warn = foldl1 max ==> maximum +warn = foldr1 max ==> maximum +warn = foldl1 min ==> minimum +warn = foldr1 min ==> minimum +warn = foldr mplus mzero ==> msum where _ = noQuickCheck -- FUNCTION -error = (\x -> x) ==> id -error = (\x y -> x) ==> const -error = (\(x,y) -> y) ==> snd -error = (\(x,y) -> x) ==> fst -warn "Use curry" = (\x y -> f (x,y)) ==> curry f -warn "Use uncurry" = (\(x,y) -> f x y) ==> uncurry f where note = IncreasesLaziness -error "Redundant $" = (($) . f) ==> f -error "Redundant $" = (f $) ==> f -warn = (\x -> y) ==> const y where _ = isAtom y && not (isWildcard y) -error "Redundant flip" = flip f x y ==> f y x where _ = isApp original -warn = (\a b -> g (f a) (f b)) ==> g `Data.Function.on` f -error "Evaluate" = id x ==> x -error "Redundant id" = id . x ==> x -error "Redundant id" = x . id ==> x +warn = (\x -> x) ==> id +warn = (\x y -> x) ==> const +warn = (\(x,y) -> y) ==> snd +warn = (\(x,y) -> x) ==> fst +hint "Use curry" = (\x y -> f (x,y)) ==> curry f +hint "Use uncurry" = (\(x,y) -> f x y) ==> uncurry f where note = IncreasesLaziness +warn "Redundant $" = (($) . f) ==> f +warn "Redundant $" = (f $) ==> f +hint = (\x -> y) ==> const y where _ = isAtom y && not (isWildcard y) +warn "Redundant flip" = flip f x y ==> f y x where _ = isApp original +hint = (\a b -> g (f a) (f b)) ==> g `Data.Function.on` f +warn "Evaluate" = id x ==> x +warn "Redundant id" = id . x ==> x +warn "Redundant id" = x . id ==> x -- CHAR -error = a >= 'a' && a <= 'z' ==> isAsciiLower a -error = a >= 'A' && a <= 'Z' ==> isAsciiUpper a -error = a >= '0' && a <= '9' ==> isDigit a -error = a >= '0' && a <= '7' ==> isOctDigit a -error = isLower a || isUpper a ==> isAlpha a -error = isUpper a || isLower a ==> isAlpha a +warn = a >= 'a' && a <= 'z' ==> isAsciiLower a +warn = a >= 'A' && a <= 'Z' ==> isAsciiUpper a +warn = a >= '0' && a <= '9' ==> isDigit a +warn = a >= '0' && a <= '7' ==> isOctDigit a +warn = isLower a || isUpper a ==> isAlpha a +warn = isUpper a || isLower a ==> isAlpha a -- BOOL -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 -error "Redundant if" = (if a then (if b then t else f) else f) ==> if a && b then t else f -error "Redundant if" = (if x then True else y) ==> x || y where _ = notEq y False -error "Redundant if" = (if x then y else False) ==> x && y where _ = notEq y True -warn "Use if" = case a of {True -> t; False -> f} ==> if a then t else f -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 = 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 = IncreasesLaziness +warn "Redundant ==" = x == True ==> x +hint "Redundant ==" = x == False ==> not x +warn "Redundant ==" = True == a ==> a +hint "Redundant ==" = False == a ==> not a +warn "Redundant /=" = a /= True ==> not a +hint "Redundant /=" = a /= False ==> a +warn "Redundant /=" = True /= a ==> not a +hint "Redundant /=" = False /= a ==> a +warn "Redundant if" = (if a then x else x) ==> x where note = IncreasesLaziness +warn "Redundant if" = (if a then True else False) ==> a +warn "Redundant if" = (if a then False else True) ==> not a +warn "Redundant if" = (if a then t else (if b then t else f)) ==> if a || b then t else f +warn "Redundant if" = (if a then (if b then t else f) else f) ==> if a && b then t else f +warn "Redundant if" = (if x then True else y) ==> x || y where _ = notEq y False +warn "Redundant if" = (if x then y else False) ==> x && y where _ = notEq y True +hint "Use if" = case a of {True -> t; False -> f} ==> if a then t else f +hint "Use if" = case a of {False -> f; True -> t} ==> if a then t else f +hint "Use if" = case a of {True -> t; _ -> f} ==> if a then t else f +hint "Use if" = case a of {False -> f; _ -> t} ==> if a then t else f +hint "Redundant if" = (if c then (True, x) else (False, x)) ==> (c, x) where note = IncreasesLaziness +hint "Redundant if" = (if c then (False, x) else (True, x)) ==> (not c, x) where note = IncreasesLaziness +hint = or [x, y] ==> x || y +hint = or [x, y, z] ==> x || y || z +hint = and [x, y] ==> x && y +hint = and [x, y, z] ==> x && y && z +warn "Redundant if" = (if x then False else y) ==> not x && y where _ = notEq y True +warn "Redundant if" = (if x then y else True) ==> not x || y where _ = notEq y False +warn "Redundant not" = not (not x) ==> x +-- warn "Too strict if" = (if c then f x else f y) ==> f (if c then x else y) where note = IncreasesLaziness -- also breaks types, see #87 -- ARROW -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 -warn = (\x -> (f x, g x)) ==> f Control.Arrow.&&& g -warn = (\(x,y) -> (f x,y)) ==> Control.Arrow.first f -warn = (\(x,y) -> (x,f y)) ==> Control.Arrow.second f -warn = (f (fst x), g (snd x)) ==> (f Control.Arrow.*** g) x -warn "Redundant pair" = (fst x, snd x) ==> x where note = DecreasesLaziness +warn = id *** g ==> second g +warn = f *** id ==> first f +warn = zip (map f x) (map g x) ==> map (f Control.Arrow.&&& g) x +hint = (\(x,y) -> (f x, g y)) ==> f Control.Arrow.*** g +hint = (\x -> (f x, g x)) ==> f Control.Arrow.&&& g +hint = (\(x,y) -> (f x,y)) ==> Control.Arrow.first f +hint = (\(x,y) -> (x,f y)) ==> Control.Arrow.second f +hint = (f (fst x), g (snd x)) ==> (f Control.Arrow.*** g) x +hint "Redundant pair" = (fst x, snd x) ==> x where note = DecreasesLaziness -- FUNCTOR -error "Functor law" = fmap f (fmap g x) ==> fmap (f . g) x where _ = noQuickCheck -error "Functor law" = f <$> g <$> x ==> f . g <$> x where _ = noQuickCheck -error "Functor law" = fmap id ==> id where _ = noQuickCheck -error "Functor law" = id <$> x ==> x where _ = noQuickCheck -warn = fmap f $ x ==> f Control.Applicative.<$> x +warn "Functor law" = fmap f (fmap g x) ==> fmap (f . g) x where _ = noQuickCheck +warn "Functor law" = f <$> g <$> x ==> f . g <$> x where _ = noQuickCheck +warn "Functor law" = fmap id ==> id where _ = noQuickCheck +warn "Functor law" = id <$> x ==> x where _ = noQuickCheck +hint = fmap f $ x ==> f Control.Applicative.<$> x where _ = (isApp x || isAtom x) && noQuickCheck -- MONAD -error "Monad law, left identity" = return a >>= f ==> f a where _ = noQuickCheck -error "Monad law, left identity" = f =<< return a ==> f a where _ = noQuickCheck -error "Monad law, right identity" = m >>= return ==> m where _ = noQuickCheck -error "Monad law, right identity" = return =<< m ==> m where _ = noQuickCheck -warn = m >>= return . f ==> Control.Monad.liftM f m where _ = noQuickCheck -- cannot be fmap, because is in Functor not Monad -warn = return . f =<< m ==> Control.Monad.liftM f m where _ = noQuickCheck -error = (if x then y else return ()) ==> Control.Monad.when x $ _noParen_ y where _ = not (isAtom y) && noQuickCheck -error = (if x then y else return ()) ==> Control.Monad.when x y where _ = isAtom y && noQuickCheck -error = (if x then return () else y) ==> Control.Monad.unless x $ _noParen_ y where _ = not (isAtom y) && noQuickCheck -error = (if x then return () else y) ==> Control.Monad.unless x y where _ = isAtom y && noQuickCheck -error = sequence (map f x) ==> mapM f x where _ = noQuickCheck -error = sequence_ (map f x) ==> mapM_ f x where _ = noQuickCheck -warn = flip mapM ==> Control.Monad.forM where _ = noQuickCheck -warn = flip mapM_ ==> Control.Monad.forM_ where _ = noQuickCheck -warn = flip forM ==> mapM where _ = noQuickCheck -warn = flip forM_ ==> mapM_ where _ = noQuickCheck -error = when (not x) ==> unless x where _ = noQuickCheck -error = x >>= id ==> Control.Monad.join x where _ = noQuickCheck -error = id =<< x ==> Control.Monad.join x where _ = noQuickCheck -error = liftM f (liftM g x) ==> liftM (f . g) x where _ = noQuickCheck -warn = a >> return () ==> Control.Monad.void a +warn "Monad law, left identity" = return a >>= f ==> f a where _ = noQuickCheck +warn "Monad law, left identity" = f =<< return a ==> f a where _ = noQuickCheck +warn "Monad law, right identity" = m >>= return ==> m where _ = noQuickCheck +warn "Monad law, right identity" = return =<< m ==> m where _ = noQuickCheck +warn = liftM ==> fmap +hint = m >>= return . f ==> fmap f m where _ = noQuickCheck -- cannot be fmap, because is in Functor not Monad +hint = return . f =<< m ==> fmap f m where _ = noQuickCheck +warn = (if x then y else return ()) ==> Control.Monad.when x $ _noParen_ y where _ = not (isAtom y) && noQuickCheck +warn = (if x then y else return ()) ==> Control.Monad.when x y where _ = isAtom y && noQuickCheck +warn = (if x then return () else y) ==> Control.Monad.unless x $ _noParen_ y where _ = not (isAtom y) && noQuickCheck +warn = (if x then return () else y) ==> Control.Monad.unless x y where _ = isAtom y && noQuickCheck +warn = sequence (map f x) ==> mapM f x where _ = noQuickCheck +warn = sequence_ (map f x) ==> mapM_ f x where _ = noQuickCheck +hint = flip mapM ==> Control.Monad.forM where _ = noQuickCheck +hint = flip mapM_ ==> Control.Monad.forM_ where _ = noQuickCheck +hint = flip forM ==> mapM where _ = noQuickCheck +hint = flip forM_ ==> mapM_ where _ = noQuickCheck +warn = when (not x) ==> unless x where _ = noQuickCheck +warn = x >>= id ==> Control.Monad.join x where _ = noQuickCheck +warn = id =<< x ==> Control.Monad.join x where _ = noQuickCheck +hint = a >> return () ==> Control.Monad.void a where _ = (isAtom a || isApp a) && noQuickCheck -error = fmap (const ()) ==> Control.Monad.void where _ = noQuickCheck -error = const () <$> x ==> Control.Monad.void x where _ = noQuickCheck -error = flip (>=>) ==> (<=<) where _ = noQuickCheck -error = flip (<=<) ==> (>=>) where _ = noQuickCheck -error = flip (>>=) ==> (=<<) where _ = noQuickCheck -error = flip (=<<) ==> (>>=) where _ = noQuickCheck -warn = (\x -> f x >>= g) ==> f Control.Monad.>=> g where _ = noQuickCheck -warn = (\x -> f =<< g x) ==> f Control.Monad.<=< g where _ = noQuickCheck -error = a >> forever a ==> forever a where _ = noQuickCheck -warn = liftM2 id ==> ap where _ = noQuickCheck -error = mapM (uncurry f) (zip l m) ==> zipWithM f l m where _ = noQuickCheck +warn = fmap (const ()) ==> Control.Monad.void where _ = noQuickCheck +warn = const () <$> x ==> Control.Monad.void x where _ = noQuickCheck +warn = flip (>=>) ==> (<=<) where _ = noQuickCheck +warn = flip (<=<) ==> (>=>) where _ = noQuickCheck +warn = flip (>>=) ==> (=<<) where _ = noQuickCheck +warn = flip (=<<) ==> (>>=) where _ = noQuickCheck +hint = (\x -> f x >>= g) ==> f Control.Monad.>=> g where _ = noQuickCheck +hint = (\x -> f =<< g x) ==> f Control.Monad.<=< g where _ = noQuickCheck +warn = a >> forever a ==> forever a where _ = noQuickCheck +hint = liftM2 id ==> ap where _ = noQuickCheck +warn = mapM (uncurry f) (zip l m) ==> zipWithM f l m where _ = noQuickCheck -- STATE MONAD -error = fst (runState x y) ==> evalState x y where _ = noQuickCheck -error = snd (runState x y) ==> execState x y where _ = noQuickCheck +warn = fst (runState x y) ==> evalState x y where _ = noQuickCheck +warn = snd (runState x y) ==> execState x y where _ = noQuickCheck -- MONAD LIST -error = liftM unzip (mapM f x) ==> Control.Monad.mapAndUnzipM f x where _ = noQuickCheck -error = sequence (zipWith f x y) ==> Control.Monad.zipWithM f x y where _ = noQuickCheck -error = sequence_ (zipWith f x y) ==> Control.Monad.zipWithM_ f x y where _ = noQuickCheck -error = sequence (replicate n x) ==> Control.Monad.replicateM n x where _ = noQuickCheck -error = sequence_ (replicate n x) ==> Control.Monad.replicateM_ n x where _ = noQuickCheck -error = mapM f (replicate n x) ==> Control.Monad.replicateM n (f x) where _ = noQuickCheck -error = mapM_ f (replicate n x) ==> Control.Monad.replicateM_ n (f x) where _ = noQuickCheck -error = mapM f (map g x) ==> mapM (f . g) x where _ = noQuickCheck -error = mapM_ f (map g x) ==> mapM_ (f . g) x where _ = noQuickCheck -error = mapM id ==> sequence where _ = noQuickCheck -error = mapM_ id ==> sequence_ where _ = noQuickCheck +warn = fmap unzip (mapM f x) ==> Control.Monad.mapAndUnzipM f x where _ = noQuickCheck +warn = sequence (zipWith f x y) ==> Control.Monad.zipWithM f x y where _ = noQuickCheck +warn = sequence_ (zipWith f x y) ==> Control.Monad.zipWithM_ f x y where _ = noQuickCheck +warn = sequence (replicate n x) ==> Control.Monad.replicateM n x where _ = noQuickCheck +warn = sequence_ (replicate n x) ==> Control.Monad.replicateM_ n x where _ = noQuickCheck +warn = mapM f (replicate n x) ==> Control.Monad.replicateM n (f x) where _ = noQuickCheck +warn = mapM_ f (replicate n x) ==> Control.Monad.replicateM_ n (f x) where _ = noQuickCheck +warn = mapM f (map g x) ==> mapM (f . g) x where _ = noQuickCheck +warn = mapM_ f (map g x) ==> mapM_ (f . g) x where _ = noQuickCheck +warn = mapM id ==> sequence where _ = noQuickCheck +warn = mapM_ id ==> sequence_ where _ = noQuickCheck -- APPLICATIVE / TRAVERSABLE -error = flip traverse ==> for where _ = noQuickCheck -error = flip for ==> traverse where _ = noQuickCheck -error = flip traverse_ ==> for_ where _ = noQuickCheck -error = flip for_ ==> traverse_ where _ = noQuickCheck -error = foldr (*>) (pure ()) ==> sequenceA_ where _ = noQuickCheck -error = foldr (<|>) empty ==> asum where _ = noQuickCheck -error = liftA2 (flip ($)) ==> (<**>) where _ = noQuickCheck -error = Just <$> a <|> pure Nothing ==> optional a where _ = noQuickCheck +warn = flip traverse ==> for where _ = noQuickCheck +warn = flip for ==> traverse where _ = noQuickCheck +warn = flip traverse_ ==> for_ where _ = noQuickCheck +warn = flip for_ ==> traverse_ where _ = noQuickCheck +warn = foldr (*>) (pure ()) ==> sequenceA_ where _ = noQuickCheck +warn = foldr (<|>) empty ==> asum where _ = noQuickCheck +warn = liftA2 (flip ($)) ==> (<**>) where _ = noQuickCheck +warn = Just <$> a <|> pure Nothing ==> optional a where _ = noQuickCheck -- LIST COMP -warn "Use list comprehension" = (if b then [x] else []) ==> [x | b] -warn "Redundant list comprehension" = [x | x <- y] ==> y where _ = isVar x +hint "Use list comprehension" = (if b then [x] else []) ==> [x | b] +hint "Redundant list comprehension" = [x | x <- y] ==> y where _ = isVar x -- SEQ -error "Redundant seq" = x `seq` x ==> x -error "Redundant $!" = id $! x ==> x -error "Redundant seq" = x `seq` y ==> y where _ = isWHNF x -error "Redundant $!" = f $! x ==> f x where _ = isWHNF x -error "Redundant evaluate" = evaluate x ==> return x where _ = isWHNF x +warn "Redundant seq" = x `seq` x ==> x +warn "Redundant $!" = id $! x ==> x +warn "Redundant seq" = x `seq` y ==> y where _ = isWHNF x +warn "Redundant $!" = f $! x ==> f x where _ = isWHNF x +warn "Redundant evaluate" = evaluate x ==> return x where _ = isWHNF x -- MAYBE -error = maybe x id ==> Data.Maybe.fromMaybe x -error = maybe False (const True) ==> Data.Maybe.isJust -error = maybe True (const False) ==> Data.Maybe.isNothing -error = not (isNothing x) ==> isJust x -error = not (isJust x) ==> isNothing x -error = maybe [] (:[]) ==> maybeToList -error = catMaybes (map f x) ==> mapMaybe f x -warn = (case x of Nothing -> y; Just a -> a) ==> fromMaybe y x -error = (if isNothing x then y else f (fromJust x)) ==> maybe y f x -error = (if isJust x then f (fromJust x) else y) ==> maybe y f x -error = maybe Nothing (Just . f) ==> fmap f -warn = map fromJust . filter isJust ==> Data.Maybe.catMaybes -error = x == Nothing ==> isNothing x -error = Nothing == x ==> isNothing x -error = x /= Nothing ==> Data.Maybe.isJust x -error = Nothing /= x ==> Data.Maybe.isJust x -error = concatMap (maybeToList . f) ==> Data.Maybe.mapMaybe f -error = concatMap maybeToList ==> catMaybes -error = maybe n Just x ==> Control.Monad.mplus x n -warn = (case x of Just a -> a; Nothing -> y) ==> fromMaybe y x -error = (if isNothing x then y else fromJust x) ==> fromMaybe y x -error = (if isJust x then fromJust x else y) ==> fromMaybe y x -error = isJust x && (fromJust x == y) ==> x == Just y -error = mapMaybe f (map g x) ==> mapMaybe (f . g) x -error = fromMaybe a (fmap f x) ==> maybe a f x -error = mapMaybe id ==> catMaybes -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 = IncreasesLaziness +warn = maybe x id ==> Data.Maybe.fromMaybe x +warn = maybe False (const True) ==> Data.Maybe.isJust +warn = maybe True (const False) ==> Data.Maybe.isNothing +warn = not (isNothing x) ==> isJust x +warn = not (isJust x) ==> isNothing x +warn = maybe [] (:[]) ==> maybeToList +warn = catMaybes (map f x) ==> mapMaybe f x +hint = (case x of Nothing -> y; Just a -> a) ==> fromMaybe y x +warn = (if isNothing x then y else f (fromJust x)) ==> maybe y f x +warn = (if isJust x then f (fromJust x) else y) ==> maybe y f x +warn = maybe Nothing (Just . f) ==> fmap f +hint = map fromJust . filter isJust ==> Data.Maybe.catMaybes +warn = x == Nothing ==> isNothing x +warn = Nothing == x ==> isNothing x +warn = x /= Nothing ==> Data.Maybe.isJust x +warn = Nothing /= x ==> Data.Maybe.isJust x +warn = concatMap (maybeToList . f) ==> Data.Maybe.mapMaybe f +warn = concatMap maybeToList ==> catMaybes +warn = maybe n Just x ==> Control.Monad.mplus x n +hint = (case x of Just a -> a; Nothing -> y) ==> fromMaybe y x +warn = (if isNothing x then y else fromJust x) ==> fromMaybe y x +warn = (if isJust x then fromJust x else y) ==> fromMaybe y x +warn = isJust x && (fromJust x == y) ==> x == Just y +warn = mapMaybe f (map g x) ==> mapMaybe (f . g) x +warn = fromMaybe a (fmap f x) ==> maybe a f x +warn = mapMaybe id ==> catMaybes +hint = [x | Just x <- a] ==> Data.Maybe.catMaybes a +hint = (case m of Nothing -> Nothing; Just x -> x) ==> Control.Monad.join m +hint = maybe Nothing id ==> join +hint "Too strict maybe" = maybe (f x) (f . g) ==> f . maybe x g where note = IncreasesLaziness -- EITHER -error = [a | Left a <- a] ==> lefts a -error = [a | Right a <- a] ==> rights a -error = either Left (Right . f) ==> fmap f +warn = [a | Left a <- a] ==> lefts a +warn = [a | Right a <- a] ==> rights a +warn = either Left (Right . f) ==> fmap f -- INFIX -warn "Use infix" = elem x y ==> x `elem` y where _ = not (isInfixApp original) && not (isParen result) -warn "Use infix" = notElem x y ==> x `notElem` y where _ = not (isInfixApp original) && not (isParen result) -warn "Use infix" = isInfixOf x y ==> x `isInfixOf` y where _ = not (isInfixApp original) && not (isParen result) -warn "Use infix" = isSuffixOf x y ==> x `isSuffixOf` y where _ = not (isInfixApp original) && not (isParen result) -warn "Use infix" = isPrefixOf x y ==> x `isPrefixOf` y where _ = not (isInfixApp original) && not (isParen result) -warn "Use infix" = union x y ==> x `union` y where _ = not (isInfixApp original) && not (isParen result) -warn "Use infix" = intersect x y ==> x `intersect` y where _ = not (isInfixApp original) && not (isParen result) +hint "Use infix" = elem x y ==> x `elem` y where _ = not (isInfixApp original) && not (isParen result) +hint "Use infix" = notElem x y ==> x `notElem` y where _ = not (isInfixApp original) && not (isParen result) +hint "Use infix" = isInfixOf x y ==> x `isInfixOf` y where _ = not (isInfixApp original) && not (isParen result) +hint "Use infix" = isSuffixOf x y ==> x `isSuffixOf` y where _ = not (isInfixApp original) && not (isParen result) +hint "Use infix" = isPrefixOf x y ==> x `isPrefixOf` y where _ = not (isInfixApp original) && not (isParen result) +hint "Use infix" = union x y ==> x `union` y where _ = not (isInfixApp original) && not (isParen result) +hint "Use infix" = intersect x y ==> x `intersect` y where _ = not (isInfixApp original) && not (isParen result) -- 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 -error "Redundant negate" = negate (negate x) ==> x -warn = log y / log x ==> logBase x y -warn = sin x / cos x ==> tan x -warn = n `rem` 2 == 0 ==> even n -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 "Use 1" = x ^ 0 ==> 1 -warn = round (x - 0.5) ==> floor x +warn "Redundant fromIntegral" = fromIntegral x ==> x where _ = isLitInt x +warn "Redundant fromInteger" = fromInteger x ==> x where _ = isLitInt x +hint = x + negate y ==> x - y +hint = 0 - x ==> negate x +warn "Redundant negate" = negate (negate x) ==> x +hint = log y / log x ==> logBase x y +hint = sin x / cos x ==> tan x +hint = n `rem` 2 == 0 ==> even n +hint = n `rem` 2 /= 0 ==> odd n +hint = not (even x) ==> odd x +hint = not (odd x) ==> even x +hint = x ** 0.5 ==> sqrt x +hint "Use 1" = x ^ 0 ==> 1 +hint = round (x - 0.5) ==> floor x -- CONCURRENT -warn = mapM_ (writeChan a) ==> writeList2Chan a +hint = mapM_ (writeChan a) ==> writeList2Chan a -- EXCEPTION -warn = flip Control.Exception.catch ==> handle -warn = flip handle ==> Control.Exception.catch -warn = flip (catchJust p) ==> handleJust p -warn = flip (handleJust p) ==> catchJust 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 -warn = throw (ErrorCall a) ==> error a -error = toException NonTermination ==> nonTermination -error = toException NestedAtomically ==> nestedAtomically +hint = flip Control.Exception.catch ==> handle +hint = flip handle ==> Control.Exception.catch +hint = flip (catchJust p) ==> handleJust p +hint = flip (handleJust p) ==> catchJust p +hint = Control.Exception.bracket b (const a) (const t) ==> Control.Exception.bracket_ b a t +hint = Control.Exception.bracket (openFile x y) hClose ==> withFile x y +hint = Control.Exception.bracket (openBinaryFile x y) hClose ==> withBinaryFile x y +hint = throw (ErrorCall a) ==> error a +warn = toException NonTermination ==> nonTermination +warn = toException NestedAtomically ==> nestedAtomically -- WEAK POINTERS -error = mkWeak a a b ==> mkWeakPtr a b -error = mkWeak a (a, b) c ==> mkWeakPair a b c +warn = mkWeak a a b ==> mkWeakPtr a b +warn = mkWeak a (a, b) c ==> mkWeakPair a b c -- FOLDABLE -error "Use Foldable.forM_" = (case m of Nothing -> return (); Just x -> f x) ==> Data.Foldable.forM_ m f +warn "Use Foldable.forM_" = (case m of Nothing -> return (); Just x -> f x) ==> Data.Foldable.forM_ m f where _ = noQuickCheck -error "Use Foldable.forM_" = when (isJust m) (f (fromJust m)) ==> Data.Foldable.forM_ m f +warn "Use Foldable.forM_" = when (isJust m) (f (fromJust m)) ==> Data.Foldable.forM_ m f where _ = noQuickCheck -- EVALUATE -- TODO: These should be moved in to HSE\Evaluate.hs and applied -- through a special evaluate hint mechanism -error "Evaluate" = True && x ==> x -error "Evaluate" = False && x ==> False -error "Evaluate" = True || x ==> True -error "Evaluate" = False || x ==> x -error "Evaluate" = not True ==> False -error "Evaluate" = not False ==> True -error "Evaluate" = Nothing >>= k ==> Nothing -error "Evaluate" = k =<< Nothing ==> Nothing -error "Evaluate" = either f g (Left x) ==> f x -error "Evaluate" = either f g (Right y) ==> g y -error "Evaluate" = fst (x,y) ==> x -error "Evaluate" = snd (x,y) ==> y -error "Evaluate" = f (fst p) (snd p) ==> uncurry f p -error "Evaluate" = init [x] ==> [] -error "Evaluate" = null [] ==> True -error "Evaluate" = length [] ==> 0 -error "Evaluate" = foldl f z [] ==> z -error "Evaluate" = foldr f z [] ==> z -error "Evaluate" = foldr1 f [x] ==> x -error "Evaluate" = scanr f z [] ==> [z] -error "Evaluate" = scanr1 f [] ==> [] -error "Evaluate" = scanr1 f [x] ==> [x] -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 [] ==> ([],[]) -error "Evaluate" = lines "" ==> [] -error "Evaluate" = unwords [] ==> "" -error "Evaluate" = x - 0 ==> x -error "Evaluate" = x * 1 ==> x -error "Evaluate" = x / 1 ==> x -error "Evaluate" = concat [a] ==> a -error "Evaluate" = concat [] ==> [] -error "Evaluate" = zip [] [] ==> [] -error "Evaluate" = const x y ==> x +warn "Evaluate" = True && x ==> x +warn "Evaluate" = False && x ==> False +warn "Evaluate" = True || x ==> True +warn "Evaluate" = False || x ==> x +warn "Evaluate" = not True ==> False +warn "Evaluate" = not False ==> True +warn "Evaluate" = Nothing >>= k ==> Nothing +warn "Evaluate" = k =<< Nothing ==> Nothing +warn "Evaluate" = either f g (Left x) ==> f x +warn "Evaluate" = either f g (Right y) ==> g y +warn "Evaluate" = fst (x,y) ==> x +warn "Evaluate" = snd (x,y) ==> y +warn "Evaluate" = f (fst p) (snd p) ==> uncurry f p +warn "Evaluate" = init [x] ==> [] +warn "Evaluate" = null [] ==> True +warn "Evaluate" = length [] ==> 0 +warn "Evaluate" = foldl f z [] ==> z +warn "Evaluate" = foldr f z [] ==> z +warn "Evaluate" = foldr1 f [x] ==> x +warn "Evaluate" = scanr f z [] ==> [z] +warn "Evaluate" = scanr1 f [] ==> [] +warn "Evaluate" = scanr1 f [x] ==> [x] +warn "Evaluate" = take n [] ==> [] where note = IncreasesLaziness +warn "Evaluate" = drop n [] ==> [] where note = IncreasesLaziness +warn "Evaluate" = takeWhile p [] ==> [] +warn "Evaluate" = dropWhile p [] ==> [] +warn "Evaluate" = span p [] ==> ([],[]) +warn "Evaluate" = lines "" ==> [] +warn "Evaluate" = unwords [] ==> "" +warn "Evaluate" = x - 0 ==> x +warn "Evaluate" = x * 1 ==> x +warn "Evaluate" = x / 1 ==> x +warn "Evaluate" = concat [a] ==> a +warn "Evaluate" = concat [] ==> [] +warn "Evaluate" = zip [] [] ==> [] +warn "Evaluate" = const x y ==> x -- COMPLEX {- -- these would be a good idea, but we have not yet proven them and they seem to have side conditions -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)) +warn "Use isPrefixOf" = take (length t) s == t ==> t `Data.List.isPrefixOf` s +warn "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 -warn = (do a <- f; g a) ==> f >>= g +hint = (do a <- f; g a) ==> f >>= g where _ = (isAtom f || isApp f) -} @@ -544,7 +547,7 @@ yes = not . (/= a) -- (== a) yes = if a then 1 else if b then 1 else 2 -- if a || b then 1 else 2 no = if a then 1 else if b then 3 else 2 -yes = a >>= return . bob -- Control.Monad.liftM bob a +yes = a >>= return . bob -- fmap bob a yes = (x !! 0) + (x !! 2) -- head x yes = if b < 42 then [a] else [] -- [a | b < 42] no = take n (foo xs) == "hello" @@ -585,7 +588,7 @@ no = const . ok . toResponse $ "saved" yes = case x z of Nothing -> y z; Just pat -> pat -- fromMaybe (y z) (x z) yes = if p then s else return () -- Control.Monad.when p s -error = a $$$$ b $$$$ c ==> a . b $$$$$ c +warn = a $$$$ b $$$$ c ==> a . b $$$$$ c yes = when (not . null $ asdf) -- unless (null asdf) yes = id 1 -- 1 yes = case concat (map f x) of [] -> [] -- concatMap f x diff --git a/data/Dollar.hs b/data/Dollar.hs --- a/data/Dollar.hs +++ b/data/Dollar.hs @@ -1,7 +1,7 @@ module HLint.Dollar where -error = a $ b $ c ==> a . b $ c +warn = a $ b $ c ==> a . b $ c {- diff --git a/data/Generalise.hs b/data/Generalise.hs --- a/data/Generalise.hs +++ b/data/Generalise.hs @@ -4,8 +4,8 @@ import Data.Monoid import Control.Monad -warn = concatMap ==> (=<<) -warn = liftM ==> fmap +hint = concatMap ==> (=<<) +hint = liftM ==> fmap where _ = noQuickCheck -warn = map ==> fmap -warn = a ++ b ==> a `Data.Monoid.mappend` b +hint = map ==> fmap +hint = a ++ b ==> a `Data.Monoid.mappend` b diff --git a/data/Test.hs b/data/Test.hs --- a/data/Test.hs +++ b/data/Test.hs @@ -23,11 +23,13 @@ ignore "Test3" ignore "Test2" = ignoreTest warn = ignoreTest3 +suggest = ignoreTest4 ignore = Ignore_Test {-# ANN module "HLint: ignore Test4" #-} {-# ANN annTest2 "HLint: error" #-} {-# ANN annTest3 ("HLint: warn" :: String) #-} +{-# ANN annTest4 ("HLint: suggest" :: String) #-} {-# ANN type Ann_Test ("HLint: ignore") #-} @@ -63,6 +65,7 @@ ignoreTest = filter -- @Ignore ??? ignoreTest2 = filter -- @Error ??? ignoreTest3 = filter -- @Warning ??? +ignoreTest4 = filter -- @Suggestion ??? ignoreAny = scanr -- @Ignore ??? ignoreNew = foldr -- @Ignore ??? type Ignore_Test = Int -- @Ignore ??? @@ -70,6 +73,7 @@ annTest = foldl -- @Ignore ??? annTest2 = foldl -- @Error ??? annTest3 = scanr -- @Warning ??? +annTest4 = scanr -- @Suggestion ??? type Ann_Test = Int -- @Ignore ??? concatMap f x = concat (map f x) diff --git a/hlint.cabal b/hlint.cabal --- a/hlint.cabal +++ b/hlint.cabal @@ -1,7 +1,7 @@ -cabal-version: >= 1.6 +cabal-version: >= 1.8 build-type: Simple name: hlint -version: 1.9.26 +version: 1.9.27 license: BSD3 license-file: LICENSE category: Development @@ -29,7 +29,7 @@ extra-doc-files: README.md CHANGES.txt -tested-with: GHC==7.10.1, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +tested-with: GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 source-repository head type: git @@ -98,8 +98,8 @@ Hint.Match Hint.Monad Hint.Naming + Hint.Pattern Hint.Pragma - Hint.Structure Hint.Type Hint.Unsafe Hint.Util @@ -112,13 +112,9 @@ executable hlint - build-depends: base - hs-source-dirs: src - main-is: Main.hs + build-depends: base, hlint + main-is: src/Main.hs - ghc-options: -fno-warn-overlapping-patterns -rtsopts + ghc-options: -rtsopts if flag(threaded) ghc-options: -threaded - - if !flag(gpl) - cpp-options: -DGPL_SCARES_ME diff --git a/src/Apply.hs b/src/Apply.hs --- a/src/Apply.hs +++ b/src/Apply.hs @@ -67,7 +67,7 @@ case res of Right m -> return $ Right m Left (ParseError sl msg ctxt) -> do - i <- return $ rawIdeaN Warning "Parse error" (mkSrcSpan sl sl) ctxt Nothing [] + i <- return $ rawIdeaN Error "Parse error" (mkSrcSpan sl sl) ctxt Nothing [] i <- return $ classify [x | SettingClassify x <- s] i return $ Left i{ideaHint = if "Parse error" `isPrefixOf` msg then msg else "Parse error: " ++ msg} diff --git a/src/CmdLine.hs b/src/CmdLine.hs --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -13,7 +13,9 @@ import System.FilePath import System.IO import Language.Preprocessor.Cpphs +import Language.Haskell.Exts(defaultParseMode, baseLanguage) import Language.Haskell.Exts.Extension +import Data.Maybe import System.Environment import System.Info.Extra @@ -182,14 +184,14 @@ cmdHintFiles :: Cmd -> IO [FilePath] cmdHintFiles cmd = mapM (getHintFile $ cmdDataDir cmd) $ cmdGivenHints cmd ++ ["HLint" | null (cmdGivenHints cmd) && null (cmdWithHints cmd)] -cmdExtensions :: Cmd -> [Extension] +cmdExtensions :: Cmd -> (Language, [Extension]) cmdExtensions = getExtensions . cmdLanguage cmdCpp :: Cmd -> CppFlags cmdCpp cmd | cmdCppSimple cmd = CppSimple - | EnableExtension CPP `elem` cmdExtensions cmd = Cpphs defaultCpphsOptions + | EnableExtension CPP `elem` snd (cmdExtensions cmd) = Cpphs defaultCpphsOptions {boolopts=defaultBoolOptions{hashline=False, stripC89=True, ansi=cmdCppAnsi cmd} ,includes = cmdCppInclude cmd ,preInclude = cmdCppFile cmd @@ -266,9 +268,13 @@ if b then return x else f o xs -getExtensions :: [String] -> [Extension] -getExtensions = foldl f defaultExtensions +getExtensions :: [String] -> (Language, [Extension]) +getExtensions args = (lang, foldl f (if null langs then defaultExtensions else []) exts) where + lang = if null langs then baseLanguage defaultParseMode else fromJust $ lookup (last langs) ls + (langs, exts) = partition (isJust . flip lookup ls) args + ls = [(show x, x) | x <- knownLanguages] + f a "Haskell98" = [] f a ('N':'o':x) | Just x <- readExtension x = delete x a f a x | Just x <- readExtension x = x : delete x a diff --git a/src/Grep.hs b/src/Grep.hs --- a/src/Grep.hs +++ b/src/Grep.hs @@ -18,12 +18,12 @@ patt ++ "\n" ++ replicate (srcColumn sl - 1) ' ' ++ "^" let scope = scopeCreate $ Module an Nothing [] [] [] - let rule = hintRules [HintRule Warning "grep" scope exp (Tuple an Boxed []) Nothing []] + let rule = hintRules [HintRule Suggestion "grep" scope exp (Tuple an Boxed []) Nothing []] forM_ files $ \file -> do res <- parseModuleEx flags file Nothing case res of Left (ParseError sl msg ctxt) -> - print $ rawIdeaN Warning (if "Parse error" `isPrefixOf` msg then msg else "Parse error: " ++ msg) (mkSrcSpan sl sl) ctxt Nothing [] + print $ rawIdeaN Error (if "Parse error" `isPrefixOf` msg then msg else "Parse error: " ++ msg) (mkSrcSpan sl sl) ctxt Nothing [] Right m -> forM_ (applyHints [] rule [m]) $ \i -> print i{ideaHint="", ideaTo=Nothing} diff --git a/src/HLint.hs b/src/HLint.hs --- a/src/HLint.hs +++ b/src/HLint.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RecordWildCards, ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -module HLint(hlint, Suggestion, suggestionLocation, suggestionSeverity, Severity(..)) where +module HLint(hlint) where import Control.Applicative import Control.Monad.Extra @@ -32,25 +32,7 @@ import HSE.All --- | A suggestion - the @Show@ instance is of particular use. -newtype Suggestion = Suggestion {fromSuggestion :: Idea} - deriving (Eq,Ord) - -instance Show Suggestion where - show = show . fromSuggestion - --- | From a suggestion, extract the file location it refers to. -suggestionLocation :: Suggestion -> SrcLoc -suggestionLocation = getPointLoc . ideaSpan . fromSuggestion - - --- | From a suggestion, determine how severe it is. -suggestionSeverity :: Suggestion -> Severity -suggestionSeverity = ideaSeverity . fromSuggestion - - - --- | This function takes a list of command line arguments, and returns the given suggestions. +-- | This function takes a list of command line arguments, and returns the given hints. -- To see a list of arguments type @hlint --help@ at the console. -- This function writes to the stdout/stderr streams, unless @--quiet@ is specified. -- @@ -58,7 +40,11 @@ -- -- > do hints <- hlint ["src", "--ignore=Use map","--quiet"] -- > when (length hints > 3) $ error "Too many hints!" -hlint :: [String] -> IO [Suggestion] +-- +-- /Warning:/ The flags provided by HLint are relatively stable, but do not have the same +-- API stability guarantees as the rest of the strongly-typed API. Do not run this function +-- on a your server with untrusted input. +hlint :: [String] -> IO [Idea] hlint args = do cmd <- getCmd args case cmd of @@ -72,7 +58,8 @@ v <- getVerbosity forM_ cmdFiles $ \x -> do putStrLn $ "Parse result of " ++ x ++ ":" - res <- parseFileWithExts (cmdExtensions c) x + let (lang,exts) = cmdExtensions c + res <- parseFileWithMode defaultParseMode{baseLanguage=lang, extensions=exts} x case res of x@ParseFailed{} -> print x ParseOk m -> case v of @@ -95,7 +82,8 @@ hlintGrep :: Cmd -> IO () hlintGrep cmd@CmdGrep{..} = do encoding <- if cmdUtf8 then return utf8 else readEncoding cmdEncoding - let flags = parseFlagsSetExtensions (cmdExtensions cmd) $ defaultParseFlags{cppFlags=cmdCpp cmd, encoding=encoding} + let flags = parseFlagsSetLanguage (cmdExtensions cmd) $ + defaultParseFlags{cppFlags=cmdCpp cmd, encoding=encoding} if null cmdFiles then exitWithHelp else do @@ -105,10 +93,11 @@ else runGrep cmdPattern flags files -hlintMain :: Cmd -> IO [Suggestion] +hlintMain :: Cmd -> IO [Idea] hlintMain cmd@CmdMain{..} = do encoding <- if cmdUtf8 then return utf8 else readEncoding cmdEncoding - let flags = parseFlagsSetExtensions (cmdExtensions cmd) $ defaultParseFlags{cppFlags=cmdCpp cmd, encoding=encoding} + let flags = parseFlagsSetLanguage (cmdExtensions cmd) $ + defaultParseFlags{cppFlags=cmdCpp cmd, encoding=encoding} if null cmdFiles && not (null cmdFindHints) then do hints <- concatMapM (resolveFile cmd Nothing) cmdFindHints mapM_ (putStrLn . fst <=< findSettings2 flags) hints >> return [] @@ -118,7 +107,7 @@ withTempFile (\t -> runHlintMain cmd (Just t) flags) else runHlintMain cmd Nothing flags -runHlintMain :: Cmd -> Maybe FilePath -> ParseFlags -> IO [Suggestion] +runHlintMain :: Cmd -> Maybe FilePath -> ParseFlags -> IO [Idea] runHlintMain cmd@CmdMain{..} fp flags = do files <- concatMapM (resolveFile cmd fp) cmdFiles if null files @@ -135,7 +124,7 @@ return $ settings1 ++ settings2 ++ settings3 -runHints :: Cmd -> ParseFlags -> IO [Suggestion] +runHints :: Cmd -> ParseFlags -> IO [Idea] runHints cmd@CmdMain{..} flags = do let outStrLn = whenNormal . putStrLn settings <- readAllSettings cmd flags @@ -175,9 +164,9 @@ writeReport cmdDataDir x showideas unless cmdNoSummary $ outStrLn $ - (let i = length showideas in if i == 0 then "No suggestions" else show i ++ " suggestion" ++ ['s' | i/=1]) ++ + (let i = length showideas in if i == 0 then "No hints" else show i ++ " hint" ++ ['s' | i/=1]) ++ (let i = length hideideas in if i == 0 then "" else " (" ++ show i ++ " ignored)") - return $ map Suggestion showideas + return showideas runRefactoring :: FilePath -> FilePath -> FilePath -> String -> IO ExitCode runRefactoring rpath fin hints opts = do diff --git a/src/HSE/All.hs b/src/HSE/All.hs --- a/src/HSE/All.hs +++ b/src/HSE/All.hs @@ -1,7 +1,8 @@ module HSE.All( module X, - ParseFlags(..), defaultParseFlags, parseFlagsAddFixities, parseFlagsSetExtensions, + ParseFlags(..), defaultParseFlags, + parseFlagsAddFixities, parseFlagsSetLanguage, parseModuleEx, ParseError(..) ) where @@ -14,7 +15,6 @@ import HSE.FreeVars as X import Util import CmdLine -import Control.Exception import Data.Char import Data.List.Extra import Data.Maybe @@ -32,7 +32,8 @@ -- | Default value for 'ParseFlags'. defaultParseFlags :: ParseFlags -defaultParseFlags = ParseFlags utf8 NoCpp defaultParseMode{fixities=Just baseFixities, ignoreLinePragmas=False, extensions=defaultExtensions} +defaultParseFlags = ParseFlags utf8 NoCpp + defaultParseMode{fixities=Just baseFixities, ignoreLinePragmas=False, ignoreFunctionArity=True, extensions=defaultExtensions} parseFlagsNoLocations :: ParseFlags -> ParseFlags parseFlagsNoLocations x = x{cppFlags = case cppFlags x of Cpphs y -> Cpphs $ f y; y -> y} @@ -42,8 +43,8 @@ parseFlagsAddFixities fx x = x{hseFlags=hse{fixities = Just $ fx ++ fromMaybe [] (fixities hse)}} where hse = hseFlags x -parseFlagsSetExtensions :: [Extension] -> ParseFlags -> ParseFlags -parseFlagsSetExtensions es x = x{hseFlags=(hseFlags x){extensions = es}} +parseFlagsSetLanguage :: (Language, [Extension]) -> ParseFlags -> ParseFlags +parseFlagsSetLanguage (l, es) x = x{hseFlags=(hseFlags x){baseLanguage = l, extensions = es}} runCpp :: CppFlags -> FilePath -> String -> IO String @@ -66,7 +67,7 @@ -- The filename @-@ is treated as @stdin@. Requires some flags (often 'defaultParseFlags'), the filename, and optionally the contents of that file. parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError (Module SrcSpanInfo, [Comment])) parseModuleEx flags file str = do - str <- maybe (readFileEncoding (encoding flags) file) return str + str <- maybe (readFileEncoding' (encoding flags) file) return str str <- return $ fromMaybe str $ stripPrefix "\65279" str -- remove the BOM if it exists, see #130 ppstr <- runCpp (cppFlags flags) file str case parseFileContentsWithComments (mode flags) ppstr of @@ -78,7 +79,6 @@ let pe = case parseFileContentsWithMode (mode flags) ppstr2 of ParseFailed sl2 _ -> context (srcLine sl2) ppstr2 _ -> context (srcLine sl) ppstr - Control.Exception.evaluate $ length pe -- if we fail to parse, we may be keeping the file handle alive return $ Left $ ParseError sl msg pe where fixity = fromMaybe [] $ fixities $ hseFlags flags diff --git a/src/HSE/Bracket.hs b/src/HSE/Bracket.hs --- a/src/HSE/Bracket.hs +++ b/src/HSE/Bracket.hs @@ -77,7 +77,8 @@ needBracket i parent child | isAtom child = False - | TyFun{} <- parent, i == 1, TyFun{} <- child = False +-- a -> (b -> c) is not a required bracket, but useful for documentation about arity etc. +-- | TyFun{} <- parent, i == 1, TyFun{} <- child = False | TyFun{} <- parent, TyApp{} <- child = False | TyTuple{} <- parent = False | TyList{} <- parent = False diff --git a/src/HSE/Util.hs b/src/HSE/Util.hs --- a/src/HSE/Util.hs +++ b/src/HSE/Util.hs @@ -101,6 +101,7 @@ isSpliceDecl SpliceDecl{} = True; isSpliceDecl _ = False isNewType NewType{} = True; isNewType _ = False isRecStmt RecStmt{} = True; isRecStmt _ = False +isClsDefSig ClsDefSig{} = True; isClsDefSig _ = False isSection LeftSection{} = True isSection RightSection{} = True diff --git a/src/Hint/All.hs b/src/Hint/All.hs --- a/src/Hint/All.hs +++ b/src/Hint/All.hs @@ -19,7 +19,7 @@ import Hint.Lambda import Hint.Bracket import Hint.Naming -import Hint.Structure +import Hint.Pattern import Hint.Import import Hint.Pragma import Hint.Extensions @@ -31,7 +31,7 @@ -- This list is likely to grow over time. data HintBuiltin = HintList | HintListRec | HintMonad | HintLambda | - HintBracket | HintNaming | HintStructure | HintImport | + HintBracket | HintNaming | HintPattern | HintImport | HintPragma | HintExtensions | HintUnsafe | HintDuplicate | HintComment deriving (Show,Eq,Ord,Bounded,Enum) @@ -40,12 +40,12 @@ builtin :: HintBuiltin -> Hint builtin x = case x of HintList -> decl listHint - HintListRec -> decl listRecHint + HintListRec -> decl listRecHint HintMonad -> decl monadHint HintLambda -> decl lambdaHint HintBracket -> decl bracketHint HintNaming -> decl namingHint - HintStructure -> decl structureHint + HintPattern -> decl patternHint HintImport -> modu importHint HintPragma -> modu pragmaHint HintExtensions -> modu extensionsHint diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs --- a/src/Hint/Bracket.hs +++ b/src/Hint/Bracket.hs @@ -4,35 +4,34 @@ -- expression bracket reduction -yes = (f x) x -- @Warning f x x +yes = (f x) x -- @Suggestion f x x no = f (x x) yes = (foo) -- foo -yes = (foo bar) -- @Warning foo bar -yes = foo (bar) -- @Error bar -yes = foo ((x x)) -- @Error (x x) -yes = (f x) ||| y -- @Warning f x ||| y -yes = if (f x) then y else z -- @Warning if f x then y else z -yes = if x then (f y) else z -- @Warning if x then f y else z -yes = (a foo) :: Int -- @Warning a foo :: Int -yes = [(foo bar)] -- @Warning [foo bar] -yes = foo ((x y), z) -- @Warning (x y, z) -yes = C { f = (e h) } -- @Warning C {f = e h} -yes = \ x -> (x && x) -- @Warning \x -> x && x +yes = (foo bar) -- @Suggestion foo bar +yes = foo (bar) -- @Warning bar +yes = foo ((x x)) -- @Warning (x x) +yes = (f x) ||| y -- @Suggestion f x ||| y +yes = if (f x) then y else z -- @Suggestion if f x then y else z +yes = if x then (f y) else z -- @Suggestion if x then f y else z +yes = (a foo) :: Int -- @Suggestion a foo :: Int +yes = [(foo bar)] -- @Suggestion [foo bar] +yes = foo ((x y), z) -- @Suggestion (x y, z) +yes = C { f = (e h) } -- @Suggestion C {f = e h} +yes = \ x -> (x && x) -- @Suggestion \x -> x && x no = \(x -> y) -> z -yes = (`foo` (bar baz)) -- @Warning (`foo` bar baz) -main = do f; (print x) -- @Warning do f print x +yes = (`foo` (bar baz)) -- @Suggestion (`foo` bar baz) +main = do f; (print x) -- @Suggestion do f print x -- type bracket reduction foo :: (Int -> Int) -> Int -foo :: Int -> (Int -> Int) -- @Warning Int -> Int -> Int -foo :: (Maybe Int) -> a -- @Warning Maybe Int -> a +foo :: (Maybe Int) -> a -- @Suggestion Maybe Int -> a instance Named (DeclHead S) -data Foo = Foo {foo :: (Maybe Foo)} -- @Warning foo :: Maybe Foo +data Foo = Foo {foo :: (Maybe Foo)} -- @Suggestion foo :: Maybe Foo -- pattern bracket reduction foo (x:xs) = 1 -foo (True) = 1 -- @Error True -foo ((True)) = 1 -- @Error (True) +foo (True) = 1 -- @Warning True +foo ((True)) = 1 -- @Warning (True) foo (A{}) = True -- A{} f x = case x of (Nothing) -> 1; _ -> 2 -- Nothing @@ -103,7 +102,7 @@ f Just{} o@(remParen -> Just x) | isAtom x = bracketError msg o x : g x f Nothing o@(remParen -> Just x) | bad || isAtom x = (if isAtom x then bracketError else bracketWarning) msg o x : g x f (Just (i,o,gen)) v@(remParen -> Just x) | not $ needBracket i o x = - warn msg o (gen x) [r] : g x + suggest msg o (gen x) [r] : g x where typ = findType v r = Replace typ (toSS v) [("x", toSS x)] "x" @@ -113,27 +112,27 @@ g o = concat [f (Just (i,o,gen)) x | (i,(x,gen)) <- zip [0..] $ holes o] bracketWarning msg o x = - idea Warning msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"] + suggest msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"] bracketError msg o x = - idea Error msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"] + warn msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"] fieldDecl :: FieldDecl S -> [Idea] fieldDecl o@(FieldDecl a b v@(TyParen _ c)) - = [warn "Redundant bracket" o (FieldDecl a b c) [Replace Type (toSS v) [("x", toSS c)] "x"]] + = [suggest "Redundant bracket" o (FieldDecl a b c) [Replace Type (toSS v) [("x", toSS c)] "x"]] fieldDecl _ = [] dollar :: Exp_ -> [Idea] dollar = concatMap f . universe where - f x = [warn "Redundant $" x y [r] | InfixApp _ a d b <- [x], opExp d ~= "$" + f x = [suggest "Redundant $" x y [r] | InfixApp _ a d b <- [x], opExp d ~= "$" ,let y = App an a b, not $ needBracket 0 y a, not $ needBracket 1 y b ,let r = Replace Expr (toSS x) [("a", toSS a), ("b", toSS b)] "a b" ] ++ - [warn "Move brackets to avoid $" x (t y) [r] |(t, e@(Paren _ (InfixApp _ a1 op1 a2))) <- splitInfix x + [suggest "Move brackets to avoid $" x (t y) [r] |(t, e@(Paren _ (InfixApp _ a1 op1 a2))) <- splitInfix x ,opExp op1 ~= "$", isVar a1 || isApp a1 || isParen a1, not $ isAtom a2 , let y = App an a1 (Paren an a2) , let r = Replace Expr (toSS e) [("a", toSS a1), ("b", toSS a2)] "a (b)" ] diff --git a/src/Hint/Comment.hs b/src/Hint/Comment.hs --- a/src/Hint/Comment.hs +++ b/src/Hint/Comment.hs @@ -27,12 +27,12 @@ commentHint :: Comment -> [Idea] commentHint c@(Comment True span s) - | "#" `isSuffixOf` s && not ("#" `isPrefixOf` s) = [suggest "Fix pragma markup" c $ '#':s] - | name `elem` pragmas = [suggest "Use pragma syntax" c $ "# " ++ trim s ++ " #"] + | "#" `isSuffixOf` s && not ("#" `isPrefixOf` s) = [grab "Fix pragma markup" c $ '#':s] + | name `elem` pragmas = [grab "Use pragma syntax" c $ "# " ++ trim s ++ " #"] where name = takeWhile (\x -> isAlphaNum x || x == '_') $ dropWhile isSpace s commentHint _ = [] -suggest :: String -> Comment -> String -> Idea -suggest msg (Comment typ pos s1) s2 = rawIdea Warning msg pos (f s1) (Just $ f s2) [] refact +grab :: String -> Comment -> String -> Idea +grab msg (Comment typ pos s1) s2 = rawIdea Suggestion msg pos (f s1) (Just $ f s2) [] refact where f s = if typ then "{-" ++ s ++ "-}" else "--" ++ s refact = [ModifyComment (toRefactSrcSpan pos) (f s2)] diff --git a/src/Hint/Duplicate.hs b/src/Hint/Duplicate.hs --- a/src/Hint/Duplicate.hs +++ b/src/Hint/Duplicate.hs @@ -33,7 +33,7 @@ dupes ys = [rawIdeaN - (if length xs >= 5 then Error else Warning) + (if length xs >= 5 then Warning else Suggestion) "Reduce duplication" p1 (unlines $ map (prettyPrint . fmap (const p1)) xs) (Just $ "Combine with " ++ showSrcLoc (getPointLoc p2)) [] diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs --- a/src/Hint/Extensions.hs +++ b/src/Hint/Extensions.hs @@ -63,6 +63,10 @@ f :: Int -> (# Int, Int #) {-# LANGUAGE UnboxedTuples #-} \ f :: x -> (x, x); f x = (x, x) -- +{-# LANGUAGE DefaultSignatures #-} \ +class Val a where; val :: a -- +{-# LANGUAGE DefaultSignatures #-} \ +class Val a where; val :: a; default val :: Int -} @@ -76,7 +80,7 @@ extensionsHint :: ModuHint -extensionsHint _ x = [rawIdea Error "Unused LANGUAGE pragma" (toSrcSpan sl) +extensionsHint _ x = [rawIdea Warning "Unused LANGUAGE pragma" (toSrcSpan sl) (prettyPrint o) (Just newPragma) (warnings old new) [refact] | not $ used TemplateHaskell x -- if TH is on, can use all other extensions programmatically @@ -138,6 +142,7 @@ used PackageImports = hasS (isJust . importPkg) used QuasiQuotes = hasS isQuasiQuote used ViewPatterns = hasS isPViewPat +used DefaultSignatures = hasS isClsDefSig used DeriveDataTypeable = hasDerive ["Data","Typeable"] used DeriveFunctor = hasDerive ["Functor"] used DeriveFoldable = hasDerive ["Foldable"] diff --git a/src/Hint/Import.hs b/src/Hint/Import.hs --- a/src/Hint/Import.hs +++ b/src/Hint/Import.hs @@ -61,7 +61,7 @@ wrap :: [ImportDecl S] -> [Idea] -wrap o = [ rawIdea Error "Use fewer imports" (toSrcSpan $ ann $ head o) (f o) (Just $ f x) [] rs +wrap o = [ rawIdea Warning "Use fewer imports" (toSrcSpan $ ann $ head o) (f o) (Just $ f x) [] rs | Just (x, rs) <- [simplify o]] where f = unlines . map prettyPrint @@ -105,7 +105,7 @@ reduce1 :: ImportDecl S -> [Idea] reduce1 i@ImportDecl{..} | Just (dropAnn importModule) == fmap dropAnn importAs - = [warn "Redundant as" i i{importAs=Nothing} [RemoveAsKeyword (toSS i)]] + = [suggest "Redundant as" i i{importAs=Nothing} [RemoveAsKeyword (toSS i)]] reduce1 _ = [] @@ -131,12 +131,12 @@ = let newModuleName = y ++ "." ++ x r = [Replace R.ModuleName (toSS m) [] newModuleName] in - [warn "Use hierarchical imports" i (desugarQual i){importModule=ModuleName an newModuleName} r] + [suggest "Use hierarchical imports" i (desugarQual i){importModule=ModuleName an newModuleName} r] -- 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} - = [rawIdeaN Warning "Use hierarchical imports" (toSrcSpan $ ann i) (trimStart $ prettyPrint i) ( + = [rawIdeaN Suggestion "Use hierarchical imports" (toSrcSpan $ ann i) (trimStart $ prettyPrint i) ( Just $ unlines $ map (trimStart . prettyPrint) [f "System.IO" Nothing, f "System.IO.Error" Nothing ,f "Control.Exception" $ Just $ ImportSpecList an False [IVar an $ toNamed x | x <- ["bracket","bracket_"]]]) []] @@ -153,7 +153,7 @@ multiExport :: Module S -> [Idea] multiExport x = - [ rawIdeaN Warning "Use import/export shortcut" (toSrcSpan $ ann hd) + [ rawIdeaN Suggestion "Use import/export shortcut" (toSrcSpan $ ann hd) (unlines $ prettyPrint hd : map prettyPrint imps) (Just $ unlines $ prettyPrint newhd : map prettyPrint newimps) [] diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs --- a/src/Hint/Lambda.hs +++ b/src/Hint/Lambda.hs @@ -29,15 +29,17 @@ 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 fun mr = y mr +fun x = f . g $ x -- fun = f . g +f = foo (\y -> g x . h $ y) -- g x . h f = foo ((*) x) -- (x *) f = (*) x f = foo (flip op x) -- (`op` x) f = flip op x f = foo (flip (*) x) -- (* x) f = foo (flip (-) x) -f = foo (\x y -> fun x y) -- @Error fun +f = foo (\x y -> fun x y) -- @Warning fun f = foo (\x y -> x + y) -- (+) -f = foo (\x -> x * y) -- @Warning (* y) +f = foo (\x -> x * y) -- @Suggestion (* 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) -- \_ x -> foo x x @@ -61,7 +63,7 @@ foo = [\m x -> insert x x m] foo a b c = bar (flux ++ quux) c where flux = a -- foo a b = bar (flux ++ quux) foo a b c = bar (flux ++ quux) c where flux = c -yes = foo (\x -> Just x) -- @Error Just +yes = foo (\x -> Just x) -- @Warning Just foo = bar (\x -> (x `f`)) -- f baz = bar (\x -> (x +)) -- (+) @@ -85,17 +87,17 @@ lambdaDecl :: Decl_ -> [Idea] lambdaDecl (toFunBind -> o@(FunBind loc [Match _ name pats (UnGuardedRhs _ bod) bind])) | isNothing bind, isLambda $ fromParen bod, null (universeBi pats :: [Exp_]) = - [err "Redundant lambda" o (gen pats bod) [Replace Decl (toSS o) s1 t1]] + [warn "Redundant lambda" o (gen pats bod) [Replace Decl (toSS o) s1 t1]] | length pats2 < length pats, pvars (drop (length pats2) pats) `disjoint` varss bind - = [err "Eta reduce" (reform pats bod) (reform pats2 bod2) + = [warn "Eta reduce" (reform pats bod) (reform pats2 bod2) [ -- Disabled, see apply-refact #3 -- Replace Decl (toSS $ reform pats bod) s2 t2]] ]] where reform p b = FunBind loc [Match an name p (UnGuardedRhs an b) Nothing] - gen ps b = uncurry reform . fromLambda . Lambda an ps $ b + gen ps = uncurry reform . fromLambda . Lambda an ps (finalpats, body) = fromLambda . Lambda an pats $ bod (pats2, bod2) = etaReduce pats bod - template fps b = prettyPrint $ reform (zipWith munge ['a'..'z'] fps) (Var (ann b) (UnQual (ann b) (Ident (ann b) "body"))) + template fps b = prettyPrint $ reform (zipWith munge ['a'..'z'] fps) (toNamed "body") munge :: Char -> Pat_ -> Pat_ munge ident p@(PWildCard _) = p munge ident p = PVar (ann p) (Ident (ann p) [ident]) @@ -112,23 +114,24 @@ etaReduce ps (App _ x (Var _ (UnQual _ (Ident _ y)))) | ps /= [], PVar _ (Ident _ p) <- last ps, p == y, p /= "mr", y `notElem` vars x = etaReduce (init ps) x +etaReduce ps (InfixApp a x (isDol -> True) y) = etaReduce ps (App a x y) etaReduce ps x = (ps,x) --Section refactoring is not currently implemented. lambdaExp :: Maybe Exp_ -> Exp_ -> [Idea] lambdaExp p o@(Paren _ (App _ v@(Var l (UnQual _ (Symbol _ x))) y)) | isAtom y, allowLeftSection x = - [warnN "Use section" o (exp y x)] -- [Replace Expr (toSS o) subts template]] + [suggestN "Use section" o (exp y x)] -- [Replace Expr (toSS o) subts template]] where exp op rhs = LeftSection an op (toNamed rhs) -- template = prettyPrint (exp (toNamed "a") "*") -- subts = [("a", toSS y), ("*", toSS v)] lambdaExp p o@(Paren _ (App _ (App _ (view -> Var_ "flip") (Var _ x)) y)) | allowRightSection $ fromNamed x = - [warnN "Use section" o $ RightSection an (QVarOp an x) y] + [suggestN "Use section" o $ RightSection an (QVarOp an x) y] lambdaExp p o@Lambda{} | maybe True (not . isInfixApp) p, (res, refact) <- niceLambdaR [] o, not $ isLambda res = - [(if isVar res || isCon res then err else warn) "Avoid lambda" o res (refact $ toSS o)] + [(if isVar res || isCon res then warn else suggest) "Avoid lambda" o res (refact $ toSS o)] lambdaExp p o@(Lambda _ pats x) | isLambda (fromParen x), null (universeBi pats :: [Exp_]), maybe True (not . isLambda) p = - [warn "Collapse lambdas" o (Lambda an pats body) [Replace Expr (toSS o) subts template]] + [suggest "Collapse lambdas" o (Lambda an pats body) [Replace Expr (toSS o) subts template]] where (pats, body) = fromLambda o template = prettyPrint $ Lambda an (zipWith munge ['a'..'z'] pats) (toNamed "body") diff --git a/src/Hint/List.hs b/src/Hint/List.hs --- a/src/Hint/List.hs +++ b/src/Hint/List.hs @@ -44,13 +44,13 @@ listExp b (fromParen -> x) = if null res then concatMap (listExp $ isAppend x) $ children x else [head res] where - res = [warn name x x2 [r] | (name,f) <- checks + res = [suggest name x x2 [r] | (name,f) <- checks , Just (x2, subts, temp) <- [f b x] , let r = Replace Expr (toSS x) subts temp ] listPat :: Pat_ -> [Idea] listPat x = if null res then concatMap listPat $ children x else [head res] - where res = [warn name x x2 [r] + where res = [suggest name x x2 [r] | (name,f) <- pchecks , Just (x2, subts, temp) <- [f x] , let r = Replace Pattern (toSS x) subts temp ] @@ -107,7 +107,7 @@ f first _ _ = Nothing g :: Char -> Exp_ -> (String, Exp_) - g c p = ([c], Var (ann p) (toNamed [c])) + g c p = ([c], toNamed [c]) useCons False (view -> App2 op x y) | op ~= "++" , Just (x2, build) <- f x @@ -137,7 +137,7 @@ f x = concatMap g $ childrenBi x g :: Type_ -> [Idea] - g e@(fromTyParen -> x) = [warn "Use String" x (transform f x) + g e@(fromTyParen -> x) = [suggest "Use String" x (transform f x) rs | not . null $ rs] where f x = if x =~= typeListChar then typeString else x toSS = toRefactSrcSpan . toSrcSpan . ann diff --git a/src/Hint/ListRec.hs b/src/Hint/ListRec.hs --- a/src/Hint/ListRec.hs +++ b/src/Hint/ListRec.hs @@ -79,25 +79,25 @@ | [] <- vs, nil ~= "[]", InfixApp _ lhs c rhs <- cons, opExp c ~= ":" , fromParen rhs =~= recursive, xs `notElem` vars lhs - = Just $ (,,) "map" Error $ appsBracket + = Just $ (,,) "map" Warning $ appsBracket [toNamed "map", niceLambda [x] lhs, toNamed xs] | [] <- vs, App2 op lhs rhs <- view cons , vars op `disjoint` [x,xs] , fromParen rhs == recursive, xs `notElem` vars lhs - = Just $ (,,) "foldr" Warning $ appsBracket + = Just $ (,,) "foldr" Suggestion $ appsBracket [toNamed "foldr", niceLambda [x] $ appsBracket [op,lhs], nil, toNamed xs] | [v] <- vs, view nil == Var_ v, App _ r lhs <- cons, r =~= recursive , xs `notElem` vars lhs - = Just $ (,,) "foldl" Warning $ appsBracket + = Just $ (,,) "foldl" Suggestion $ appsBracket [toNamed "foldl", niceLambda [v,x] lhs, toNamed v, toNamed xs] | [v] <- vs, App _ ret res <- nil, ret ~= "return", res ~= "()" || view res == Var_ v , [Generator _ (view -> PVar_ b1) e, Qualifier _ (fromParen -> App _ r (view -> Var_ b2))] <- asDo cons , b1 == b2, r == recursive, xs `notElem` vars e , name <- "foldM" ++ ['_' | res ~= "()"] - = Just $ (,,) name Warning $ appsBracket + = Just $ (,,) name Suggestion $ appsBracket [toNamed name, niceLambda [v,x] e, toNamed v, toNamed xs] | otherwise = Nothing diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -20,7 +20,7 @@ yes = do x <- bar; x -- do join bar no = do x <- bar; x; x {-# LANGUAGE RecursiveDo #-}; no = mdo hook <- mkTrigger pat (act >> rmHook hook) ; return hook -yes = do x <- return y; foo x -- @Warning do let x = y; foo x +yes = do x <- return y; foo x -- @Suggestion 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 @@ -55,14 +55,14 @@ monadExp :: Decl_ -> Exp_ -> [Idea] monadExp decl x = case x of (view -> App2 op x1 x2) | op ~= ">>" -> f x1 - Do _ xs -> [err "Redundant return" x (Do an y) rs | Just (y, rs) <- [monadReturn xs]] ++ - [err "Use join" x (Do an y) rs | Just (y, rs) <- [monadJoin xs ['a'..'z']]] ++ - [err "Redundant do" x y [Replace Expr (toSS x) [("y", toSS y)] "y"] | [Qualifier _ y] <- [xs]] ++ - [warn "Use let" x (Do an y) rs | Just (y, rs) <- [monadLet xs]] ++ + Do _ xs -> [warn "Redundant return" x (Do an y) rs | Just (y, rs) <- [monadReturn xs]] ++ + [warn "Use join" x (Do an y) rs | Just (y, rs) <- [monadJoin xs ['a'..'z']]] ++ + [warn "Redundant do" x y [Replace Expr (toSS x) [("y", toSS y)] "y"] | [Qualifier _ y] <- [xs]] ++ + [suggest "Use let" x (Do an y) rs | Just (y, rs) <- [monadLet xs]] ++ concat [f x | Qualifier _ x <- init xs] _ -> [] where - f x = [err ("Use " ++ name) x y r | Just (name,y, r) <- [monadCall x], fromNamed decl /= name] + f x = [warn ("Use " ++ name) x y r | Just (name,y, r) <- [monadCall x], fromNamed decl /= name] middle :: (b -> d) -> (a, b, c) -> (a, d, c) middle f (a,b,c) = (a, f b, c) diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs --- a/src/Hint/Naming.hs +++ b/src/Hint/Naming.hs @@ -48,7 +48,7 @@ namingHint _ modu = naming $ Set.fromList [x | Ident _ x <- universeS modu] naming :: Set.Set String -> Decl_ -> [Idea] -naming seen x = [warnN "Use camelCase" x2 (replaceNames res x2) | not $ null res] +naming seen x = [suggestN "Use camelCase" x2 (replaceNames res x2) | not $ null res] where res = [(n,y) | n <- nub $ getNames x, Just y <- [suggestName n], not $ y `Set.member` seen] x2 = shorten x diff --git a/src/Hint/Pattern.hs b/src/Hint/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Pattern.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE ViewPatterns, PatternGuards #-} + +{- + Improve the structure of code + + +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 +foo b | c <- f b = c + b +foo b | c <- f b = c where f = here +foo b | c <- f b = c where foo = b +foo b | c <- f b = c \ + | c <- f b = c +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 +foo (Bar _ _ _ _) = x -- Bar{} +foo (Bar _ x _ _) = x +foo (Bar _ _) = x +foo = case f v of _ -> x -- x +foo = case v of v -> x -- x +foo = case v of z -> z +foo = case v of _ | False -> x +foo = case v of !True -> x -- True +foo = case v of !(Just x) -> x -- (Just x) +foo = case v of !(x : xs) -> x -- (x:xs) +foo = case v of !1 -> x -- 1 +foo = case v of !x -> x +foo = case v of !(I# x) -> y -- (I# x) +foo = let ~x = 1 in y -- x +foo = let ~(x:xs) = y in z +foo = let !x = undefined in y +foo = let !(I# x) = 4 in x +foo = let !(Just x) = Nothing in 3 +foo = 1 where f !False = 2 -- False +foo = 1 where !False = True +foo = 1 where g (Just !True) = Nothing -- True +foo = 1 where Just !True = Nothing +foo otherwise = 1 -- _ + +-} + + +module Hint.Pattern(patternHint) where + +import Hint.Type +import Data.Function +import Data.List.Extra +import Data.Tuple +import Data.Maybe +import Data.Either +import Refact.Types hiding (RType(Pattern, Match)) +import qualified Refact.Types as R (RType(Pattern, Match), SrcSpan) + + +patternHint :: DeclHint +patternHint _ _ x = + concatMap (uncurry hints . swap) (asPattern x) ++ + -- PatBind (used in Let and Where) contains lazy-by-default patterns, everything else is strict + concatMap (patHint False) (universeBi [p | PatBind _ p _ _ <- universe x]) ++ + concatMap (patHint True) (universeBi $ transform noPatBind x) ++ + concatMap expHint (universeBi x) + where + noPatBind (PatBind a _ b c) = PatBind a (PWildCard a) b c + noPatBind x = x + + +hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea] +hints gen (Pattern l rtype pat (UnGuardedRhs d bod) bind) + | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GuardedRhss d guards) bind) [refactoring]] + where rawGuards = asGuards bod + mkGuard a = GuardedRhs an [Qualifier an a] + guards = map (uncurry mkGuard) rawGuards + (lhs, rhs) = unzip rawGuards + mkTemplate c ps = + -- Check if the expression has been injected or is natural + let checkAn p v = if ann p == an then Left p else Right ( c ++ [v], toSS p) + in zipWith checkAn ps ['1' .. '9'] + patSubts = case pat of + [p] -> [Left p] -- Substitution doesn't work properly for PatBinds + -- This will probably produce + -- unexpected results if the pattern + -- contains any template variables + ps -> mkTemplate "p100" ps + guardSubts = mkTemplate "g100" lhs + exprSubts = mkTemplate "e100" rhs + templateGuards = zipWith (mkGuard `on` toString) guardSubts exprSubts + toString (Left e) = e + toString (Right (v, _)) = toNamed v + template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString patSubts) (GuardedRhss d templateGuards) bind) []) + f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)] + f = rights + refactoring = Replace rtype (toRefactSrcSpan . toSrcSpan $ l) (f patSubts ++ f guardSubts ++ f exprSubts) template + +{- +-- Do not suggest view patterns, they aren't something everyone likes sufficiently +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 bind) + , vars op `disjoint` decsBind, pvars pats `disjoint` vars op, pvars pat `disjoint` pvars pats + = [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 bind +-} + +hints gen (Pattern l t pats (GuardedRhss _ [GuardedRhs _ [test] bod]) bind) + | prettyPrint test `elem` ["otherwise","True"] + = [gen "Redundant guard" (Pattern l t pats (UnGuardedRhs an bod) bind) [Delete Stmt (toSS test)]] + +hints gen (Pattern l t pats bod (Just bind)) | f bind + = [gen "Redundant where" (Pattern l t pats bod Nothing) []] + where + f (BDecls _ x) = null x + f (IPBinds _ x) = null x + +hints gen (Pattern l t pats (GuardedRhss _ (unsnoc -> Just (gs, GuardedRhs _ [test] bod))) bind) + | prettyPrint test == "True" + = [gen "Use otherwise" (Pattern l t pats (GuardedRhss an $ gs ++ [GuardedRhs an [Qualifier an $ toNamed "otherwise"] bod]) bind) [Replace Expr (toSS test) [] "otherwise"]] + +hints _ _ = [] + + +asGuards :: Exp_ -> [(Exp S, Exp S)] +asGuards (Paren _ x) = asGuards x +asGuards (If _ a b c) = (a, b) : asGuards c +asGuards x = [(toNamed "otherwise", x)] + + +data Pattern = Pattern SrcSpanInfo R.RType [Pat_] (Rhs S) (Maybe (Binds S)) + +-- Invariant: Number of patterns may not change +asPattern :: Decl_ -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)] +asPattern x = concatMap decl (universeBi x) ++ concatMap alt (universeBi x) + where + decl o@(PatBind a pat rhs bind) = [(Pattern a Bind [pat] rhs bind, \msg (Pattern _ _ [pat] rhs bind) rs -> suggest msg o (PatBind a pat rhs bind) rs)] + decl (FunBind _ xs) = map match xs + decl _ = [] + match o@(Match a b pat rhs bind) = (Pattern a R.Match pat rhs bind, \msg (Pattern _ _ pat rhs bind) rs -> suggest msg o (Match a b pat rhs bind) rs) + match o@(InfixMatch a p b ps rhs bind) = (Pattern a R.Match (p:ps) rhs bind, \msg (Pattern _ _ (p:ps) rhs bind) rs -> suggest msg o (InfixMatch a p b ps rhs bind) rs) + alt o@(Alt a pat rhs bind) = [(Pattern a R.Match [pat] rhs bind, \msg (Pattern _ _ [pat] rhs bind) rs -> suggest msg o (Alt a pat rhs bind) [])] + + +patHint :: Bool -> Pat_ -> [Idea] +patHint strict o@(PApp _ name args) | length args >= 3 && all isPWildCard args = + [suggest "Use record patterns" o (PRec an name []) [Replace R.Pattern (toSS o) [] (prettyPrint $ PRec an name [])] ] +patHint strict o@(PVar _ v) | prettyPrint v == "otherwise" = [warn "Used otherwise as a pattern" o (PWildCard an) []] + +patHint strict o@(PBangPat _ x) | strict, f x = [warn "Redundant bang pattern" o x [r]] + where f (PParen _ x) = f x + f (PAsPat _ _ x) = f x + f PLit{} = True + f PApp{} = True + f PInfixApp{} = True + f _ = False + r = Replace R.Pattern (toSS o) [("x", toSS x)] "x" +patHint strict o@(PIrrPat _ x) | f x = [warn "Redundant irrefutable pattern" o x [r]] + where f (PParen _ x) = f x + f (PAsPat _ _ x) = f x + f PWildCard{} = True + f PVar{} = True + f _ = False + r = Replace R.Pattern (toSS o) [("x", toSS x)] "x" +patHint _ _ = [] + + +expHint :: Exp_ -> [Idea] +expHint o@(Case _ _ [Alt _ PWildCard{} (UnGuardedRhs _ e) Nothing]) = + [suggest "Redundant case" o e [r]] + where + r = Replace Expr (toSS o) [("x", toSS e)] "x" +expHint o@(Case _ (Var _ x) [Alt _ (PVar _ y) (UnGuardedRhs _ e) Nothing]) + | x =~= UnQual an y = + [suggest "Redundant case" o e [r]] + where + r = Replace Expr (toSS o) [("x", toSS e)] "x" +expHint _ = [] diff --git a/src/Hint/Pragma.hs b/src/Hint/Pragma.hs --- a/src/Hint/Pragma.hs +++ b/src/Hint/Pragma.hs @@ -82,7 +82,7 @@ r where f = unlines . map prettyPrint - mkIdea = rawIdea Error "Use better pragmas" + mkIdea = rawIdea Warning "Use better pragmas" languageDupes :: [ModulePragma S] -> [Idea] diff --git a/src/Hint/Structure.hs b/src/Hint/Structure.hs deleted file mode 100644 --- a/src/Hint/Structure.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -{- - Improve the structure of code - - -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 -foo b | c <- f b = c + b -foo b | c <- f b = c where f = here -foo b | c <- f b = c where foo = b -foo b | c <- f b = c \ - | c <- f b = c -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 --- FIXME: #358 foo x = x + x where -- foo x = x + x -foo x | a = b | True = d -- foo x | a = b ; | otherwise = d -foo (Bar _ _ _ _) = x -- Bar{} -foo (Bar _ x _ _) = x -foo (Bar _ _) = x -foo = case f v of _ -> x -- x -foo = case v of v -> x -- x -foo = case v of z -> z -foo = case v of _ | False -> x -foo = case v of !True -> x -- True -foo = case v of !(Just x) -> x -- (Just x) -foo = case v of !(x : xs) -> x -- (x:xs) -foo = case v of !1 -> x -- 1 -foo = case v of !x -> x -foo = let ~x = 1 in y -- x -foo = let ~(x:xs) = y in z - --} - - -module Hint.Structure(structureHint) where - -import Hint.Type -import Data.Function -import Data.List.Extra -import Data.Tuple -import Data.Maybe -import Data.Either -import Refact.Types hiding (RType(Pattern, Match)) -import qualified Refact.Types as R (RType(Pattern, Match), SrcSpan) - - -structureHint :: DeclHint -structureHint _ _ x = - concatMap (uncurry hints . swap) (asPattern x) ++ - concatMap patHint (universeBi x) ++ - concatMap expHint (universeBi x) - - -hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea] -hints gen (Pattern l rtype pat (UnGuardedRhs d bod) bind) - | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GuardedRhss d guards) bind) [refactoring]] - where rawGuards = asGuards bod - mkGuard a = GuardedRhs an [Qualifier an a] - guards = map (uncurry mkGuard) rawGuards - (lhs, rhs) = unzip rawGuards - mkTemplate c ps = - -- Check if the expression has been injected or is natural - let checkAn p v = if ann p == an then Left p else Right ( c ++ [v], toSS p) - in zipWith checkAn ps ['1' .. '9'] - patSubts = case pat of - [p] -> [Left p] -- Substitution doesn't work properly for PatBinds - -- This will probably produce - -- unexpected results if the pattern - -- contains any template variables - ps -> mkTemplate "p100" ps - guardSubts = mkTemplate "g100" lhs - exprSubts = mkTemplate "e100" rhs - templateGuards = zipWith (mkGuard `on` toString) guardSubts exprSubts - toString (Left e) = e - toString (Right (v, _)) = toNamed v - template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString patSubts) (GuardedRhss d templateGuards) bind) []) - f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)] - f = rights - refactoring = Replace rtype (toRefactSrcSpan . toSrcSpan $ l) (f patSubts ++ f guardSubts ++ f exprSubts) template - -{- --- Do not suggest view patterns, they aren't something everyone likes sufficiently -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 bind) - , vars op `disjoint` decsBind, pvars pats `disjoint` vars op, pvars pat `disjoint` pvars pats - = [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 bind --} - -hints gen (Pattern l t pats (GuardedRhss _ [GuardedRhs _ [test] bod]) bind) - | prettyPrint test `elem` ["otherwise","True"] - = [gen "Redundant guard" (Pattern l t pats (UnGuardedRhs an bod) bind) [Delete Stmt (toSS test)]] - -hints gen (Pattern l t pats bod (Just bind)) | f bind - = [gen "Redundant where" (Pattern l t pats bod Nothing) []] - where - f (BDecls _ x) = null x - f (IPBinds _ x) = null x - -hints gen (Pattern l t pats (GuardedRhss _ (unsnoc -> Just (gs, GuardedRhs _ [test] bod))) bind) - | prettyPrint test == "True" - = [gen "Use otherwise" (Pattern l t pats (GuardedRhss an $ gs ++ [GuardedRhs an [Qualifier an $ toNamed "otherwise"] bod]) bind) [Replace Expr (toSS test) [] "otherwise"]] - -hints _ _ = [] - - -asGuards :: Exp_ -> [(Exp S, Exp S)] -asGuards (Paren _ x) = asGuards x -asGuards (If _ a b c) = (a, b) : asGuards c -asGuards x = [(toNamed "otherwise", x)] - - -data Pattern = Pattern SrcSpanInfo R.RType [Pat_] (Rhs S) (Maybe (Binds S)) - --- Invariant: Number of patterns may not change -asPattern :: Decl_ -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)] -asPattern x = concatMap decl (universeBi x) ++ concatMap alt (universeBi x) - where - decl o@(PatBind a pat rhs bind) = [(Pattern a Bind [pat] rhs bind, \msg (Pattern _ _ [pat] rhs bind) rs -> warn msg o (PatBind a pat rhs bind) rs)] - decl (FunBind _ xs) = map match xs - decl _ = [] - match o@(Match a b pat rhs bind) = (Pattern a R.Match pat rhs bind, \msg (Pattern _ _ pat rhs bind) rs -> warn msg o (Match a b pat rhs bind) rs) - match o@(InfixMatch a p b ps rhs bind) = (Pattern a R.Match (p:ps) rhs bind, \msg (Pattern _ _ (p:ps) rhs bind) rs -> warn msg o (InfixMatch a p b ps rhs bind) rs) - alt o@(Alt a pat rhs bind) = [(Pattern a R.Match [pat] rhs bind, \msg (Pattern _ _ [pat] rhs bind) rs -> warn msg o (Alt a pat rhs bind) [])] - - - --- Should these hints be in the same module? They are less structure, and more about pattern matching --- Or perhaps the entire module should be renamed Pattern, since it's all about patterns -patHint :: Pat_ -> [Idea] -patHint o@(PApp _ name args) | length args >= 3 && all isPWildCard args = - [warn "Use record patterns" o (PRec an name []) [Replace R.Pattern (toSS o) [] (prettyPrint $ PRec an name [])] ] - -patHint o@(PBangPat _ x) | f x = [err "Redundant bang pattern" o x [r]] - where f (PParen _ x) = f x - f (PAsPat _ _ x) = f x - f PLit{} = True - f PApp{} = True - f PInfixApp{} = True - f _ = False - r = Replace R.Pattern (toSS o) [("x", toSS x)] "x" -patHint o@(PIrrPat _ x) | f x = [err "Redundant irrefutable pattern" o x [r]] - where f (PParen _ x) = f x - f (PAsPat _ _ x) = f x - f PWildCard{} = True - f PVar{} = True - f _ = False - r = Replace R.Pattern (toSS o) [("x", toSS x)] "x" -patHint _ = [] - - -expHint :: Exp_ -> [Idea] -expHint o@(Case _ _ [Alt _ PWildCard{} (UnGuardedRhs _ e) Nothing]) = - [warn "Redundant case" o e [r]] - where - r = Replace Expr (toSS o) [("x", toSS e)] "x" -expHint o@(Case _ (Var _ x) [Alt _ (PVar _ y) (UnGuardedRhs _ e) Nothing]) - | x =~= UnQual an y = - [warn "Redundant case" o e [r]] - where - r = Replace Expr (toSS o) [("x", toSS e)] "x" -expHint _ = [] diff --git a/src/Hint/Unsafe.hs b/src/Hint/Unsafe.hs --- a/src/Hint/Unsafe.hs +++ b/src/Hint/Unsafe.hs @@ -25,7 +25,7 @@ unsafeHint :: ModuHint unsafeHint _ m = - [ rawIdea Error "Missing NOINLINE pragma" (toSrcSpan $ ann d) + [ rawIdea Warning "Missing NOINLINE pragma" (toSrcSpan $ ann d) (prettyPrint d) (Just $ dropWhile isSpace (prettyPrint $ gen x) ++ "\n" ++ prettyPrint d) [] [InsertComment (toSS d) (prettyPrint $ gen x)] diff --git a/src/Hint/Util.hs b/src/Hint/Util.hs --- a/src/Hint/Util.hs +++ b/src/Hint/Util.hs @@ -1,6 +1,6 @@ {-# LANGUAGE PatternGuards, ViewPatterns #-} -module Hint.Util where +module Hint.Util(niceLambda, simplifyExp, niceLambdaR) where import HSE.All import Data.List.Extra @@ -26,6 +26,11 @@ -- \ -> e ==> e niceLambdaR [] x = (x, const []) + +-- \vs v -> e $ v ==> \vs -> e +niceLambdaR (unsnoc -> Just (vs, v)) (InfixApp _ e (isDol -> True) (view -> Var_ v2)) + | v == v2, vars e `disjoint` [v] + = niceLambdaR vs e -- \xs -> e xs ==> e niceLambdaR xs (fromAppsWithLoc -> e) | map view xs2 == map Var_ xs, vars e2 `disjoint` xs, not $ null e2 = diff --git a/src/Idea.hs b/src/Idea.hs --- a/src/Idea.hs +++ b/src/Idea.hs @@ -20,7 +20,7 @@ ,ideaFrom :: String -- ^ The contents of the source code the idea relates to. ,ideaTo :: Maybe String -- ^ The suggested replacement, or 'Nothing' for no replacement (e.g. on parse errors). ,ideaNote :: [Note] -- ^ Notes about the effect of applying the replacement. - , ideaRefactoring :: [Refactoring R.SrcSpan] -- ^ How to perform this idea + ,ideaRefactoring :: [Refactoring R.SrcSpan] -- ^ How to perform this idea } deriving (Eq,Ord) @@ -38,6 +38,7 @@ ,("from", show ideaFrom) ,("to", maybe "null" show ideaTo) ,("note", show $ map (show . show) ideaNote) + ,("refactorings", show . show $ ideaRefactoring) ] where mkPair (k, v) = show k ++ ":" ++ v @@ -72,12 +73,12 @@ idea severity hint from to = rawIdea severity hint (toSrcSpan $ ann from) (f from) (Just $ f to) [] where f = trimStart . prettyPrint +suggest = idea Suggestion warn = idea Warning -err = idea Error ideaN severity hint from to = rawIdea severity hint (toSrcSpan $ ann from) (f from) (Just $ f to) [] [] where f = trimStart . prettyPrint +suggestN = ideaN Suggestion warnN = ideaN Warning -errN = ideaN Error diff --git a/src/Language/Haskell/HLint.hs b/src/Language/Haskell/HLint.hs --- a/src/Language/Haskell/HLint.hs +++ b/src/Language/Haskell/HLint.hs @@ -5,6 +5,39 @@ This module provides a library interface to HLint, strongly modelled on the command line interface. -} -module Language.Haskell.HLint(module HLint) where +module Language.Haskell.HLint(hlint, Suggestion, suggestionLocation, suggestionSeverity, Severity(..)) where -import HLint +import qualified HLint +import Settings +import Idea +import HSE.All + + +-- | This function takes a list of command line arguments, and returns the given suggestions. +-- To see a list of arguments type @hlint --help@ at the console. +-- This function writes to the stdout/stderr streams, unless @--quiet@ is specified. +-- +-- As an example: +-- +-- > do hints <- hlint ["src", "--ignore=Use map","--quiet"] +-- > when (length hints > 3) $ error "Too many hints!" +hlint :: [String] -> IO [Suggestion] +hlint = fmap (map Suggestion_) . HLint.hlint + + + +-- | A suggestion - the @Show@ instance is of particular use. +newtype Suggestion = Suggestion_ {fromSuggestion :: Idea} + deriving (Eq,Ord) + +instance Show Suggestion where + show = show . fromSuggestion + +-- | From a suggestion, extract the file location it refers to. +suggestionLocation :: Suggestion -> SrcLoc +suggestionLocation = getPointLoc . ideaSpan . fromSuggestion + + +-- | From a suggestion, determine how severe it is. +suggestionSeverity :: Suggestion -> Severity +suggestionSeverity = ideaSeverity . fromSuggestion diff --git a/src/Language/Haskell/HLint3.hs b/src/Language/Haskell/HLint3.hs --- a/src/Language/Haskell/HLint3.hs +++ b/src/Language/Haskell/HLint3.hs @@ -3,7 +3,9 @@ -- | /WARNING: This module represents the evolving second version of the HLint API./ -- /It will be renamed to drop the "3" in the next major version./ -- --- This module provides a way to apply HLint hints. As an example of approximating the @hlint@ experience: +-- This module provides a way to apply HLint hints. If you want to just run @hlint@ in-process +-- and collect the results see 'hlint'. If you want to approximate the @hlint@ experience with +-- a more structured API try: -- -- @ -- (flags, classify, hint) <- 'autoSettings' @@ -11,7 +13,7 @@ -- print $ 'applyHints' classify hint [m] -- @ module Language.Haskell.HLint3( - applyHints, + hlint, applyHints, -- * Idea data type Idea(..), Severity(..), Note(..), -- * Settings @@ -30,6 +32,7 @@ import Settings hiding (findSettings) import Idea import Apply +import HLint import Hint.Type import Hint.All import CmdLine @@ -74,7 +77,7 @@ -- FIXME: Two things that could be supported (but aren't) are 'cmdGivenHints' and 'cmdWithHints'. (fixities, classify, hints) <- findSettings (readSettingsFile $ Just cmdDataDir) Nothing encoding <- if cmdUtf8 then return utf8 else readEncoding cmdEncoding - let flags = parseFlagsSetExtensions (cmdExtensions cmd) $ parseFlagsAddFixities fixities $ + let flags = parseFlagsSetLanguage (cmdExtensions cmd) $ parseFlagsAddFixities fixities $ defaultParseFlags{cppFlags = cmdCpp cmd, encoding = encoding} let ignore = [Classify Ignore x "" "" | x <- cmdIgnore] return (flags, classify ++ ignore, resolveHints hints) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,7 +1,7 @@ module Main where -import Language.Haskell.HLint +import Language.Haskell.HLint3 import Control.Monad import System.Environment import System.Exit diff --git a/src/Report.hs b/src/Report.hs --- a/src/Report.hs +++ b/src/Report.hs @@ -8,6 +8,7 @@ import Data.Maybe import Data.Version import System.FilePath +import System.IO.Extra import HSE.All import Paths_hlint import HsColour @@ -15,7 +16,7 @@ writeTemplate :: FilePath -> [(String,[String])] -> FilePath -> IO () writeTemplate dataDir content to = do - src <- readFile $ dataDir "report_template.html" + src <- readFile' $ dataDir "report_template.html" writeFile to $ unlines $ concatMap f $ lines src where f ('$':xs) = fromMaybe ['$':xs] $ lookup xs content diff --git a/src/Settings.hs b/src/Settings.hs --- a/src/Settings.hs +++ b/src/Settings.hs @@ -25,16 +25,19 @@ -- | How severe an issue is. data Severity = Ignore -- ^ The issue has been explicitly ignored and will usually be hidden (pass @--show@ on the command line to see ignored ideas). - | Warning -- ^ Warnings are things that some people may consider improvements, but some may not. - | Error -- ^ Errors are suggestions that are nearly always a good idea to apply. + | Suggestion -- ^ Suggestions are things that some people may consider improvements, but some may not. + | Warning -- ^ Warnings are suggestions that are nearly always a good idea to apply. + | Error -- ^ Available as a setting for the user. deriving (Eq,Ord,Show,Read,Bounded,Enum) getSeverity :: String -> Maybe Severity getSeverity "ignore" = Just Ignore getSeverity "warn" = Just Warning getSeverity "warning" = Just Warning -getSeverity "error" = Just Error -getSeverity "hint" = Just Error +getSeverity "suggest" = Just Suggestion +getSeverity "suggestion" = Just Suggestion +getSeverity "error" = Just Error +getSeverity "hint" = Just Suggestion getSeverity _ = Nothing diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -2,7 +2,7 @@ module Util( defaultExtensions, - Encoding, defaultEncoding, readFileEncoding, readEncoding, useEncoding, + Encoding, defaultEncoding, readFileEncoding', readEncoding, useEncoding, gzip, universeParentBi, descendIndex, exitMessage ) where @@ -12,7 +12,7 @@ import Data.Char import Data.List import System.Exit -import System.IO.Extra hiding (readFileEncoding) +import System.IO.Extra hiding (readFileEncoding') import System.IO.Unsafe import Unsafe.Coerce import Data.Data @@ -35,11 +35,15 @@ useEncoding :: Handle -> Encoding -> IO () useEncoding = hSetEncoding -readFileEncoding :: Encoding -> FilePath -> IO String -readFileEncoding enc file = do - h <- if file == "-" then return stdin else openFile file ReadMode +readFileEncoding' :: Encoding -> FilePath -> IO String +readFileEncoding' enc "-" = do + useEncoding stdin enc + getContents +readFileEncoding' enc file = withFile file ReadMode $ \h -> do useEncoding h enc - hGetContents h + s <- hGetContents h + evaluate $ length s + return s -- | Create an encoding from a string, or throw an error if the encoding is not known.