summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNeilMitchell <>2018-01-12 20:13:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-01-12 20:13:00 (GMT)
commitc19671a423554d0dd3d03899eaa9d1cdc02580c6 (patch)
tree8f7f5c626a79076d7903dc171eb27621f1582ac9
parentd742b135e67cc269159504e19ea0cafaf0d2c193 (diff)
version 2.0.132.0.13
-rw-r--r--CHANGES.txt4
-rw-r--r--LICENSE2
-rw-r--r--README.md108
-rw-r--r--hlint.cabal6
-rw-r--r--src/Apply.hs6
-rw-r--r--src/CmdLine.hs2
-rw-r--r--src/Config/Yaml.hs6
-rw-r--r--src/HSE/Scope.hs10
-rw-r--r--src/HSE/Unify.hs8
-rw-r--r--src/Hint/Bracket.hs13
-rw-r--r--src/Hint/Extensions.hs8
-rw-r--r--src/Hint/Monad.hs17
-rw-r--r--src/Hint/Restrict.hs6
-rw-r--r--src/Hint/Type.hs11
-rw-r--r--src/HsColour.hs7
-rw-r--r--src/Idea.hs6
-rw-r--r--src/Language/Haskell/HLint3.hs5
-rw-r--r--src/Test/Annotations.hs29
18 files changed, 157 insertions, 97 deletions
diff --git a/CHANGES.txt b/CHANGES.txt
index e901185..6ffa6c4 100644
--- a/CHANGES.txt
+++ b/CHANGES.txt
@@ -1,5 +1,9 @@
Changelog for HLint
+2.0.13, released 2018-01-12
+ #376, suggest <$> instead of x <- foo; return $ f x
+ #401, suggest removing brackets for (f . g) <$> x
+ Add Semigroup instances
2.0.12, released 2017-12-12
Don't suggest Control.Arrow
Upgrade to haskell-src-exts-1.20
diff --git a/LICENSE b/LICENSE
index 39ee0e3..c28caca 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright Neil Mitchell 2006-2017.
+Copyright Neil Mitchell 2006-2018.
All rights reserved.
Redistribution and use in source and binary forms, with or without
diff --git a/README.md b/README.md
index 8cb0f79..2f3c3bf 100644
--- a/README.md
+++ b/README.md
@@ -7,10 +7,6 @@ HLint is a tool for suggesting possible improvements to Haskell code. These sugg
* [Customizing the hints](#customizing-the-hints)
* [Hacking HLint](#hacking-hlint)
-### Acknowledgements
-
-This program has only been made possible by the presence of the [haskell-src-exts](https://github.com/haskell-suite/haskell-src-exts) package, and many improvements have been made by [Niklas Broberg](http://www.nbroberg.se) in response to feature requests. Additionally, many people have provided help and patches, including Lennart Augustsson, Malcolm Wallace, Henk-Jan van Tuyl, Gwern Branwen, Alex Ott, Andy Stewart, Roman Leshchinskiy, Johannes Lippmann, Iustin Pop, Steve Purcell, Mitchell Rosen and others.
-
### Bugs and limitations
Bugs can be reported [on the bug tracker](https://github.com/ndmitchell/hlint/issues). There are some issues that I do not intend to fix:
@@ -27,28 +23,29 @@ Installation follows the standard pattern of any Haskell library or program: typ
Once HLint is installed, run `hlint source` where `source` is either a Haskell file, or a directory containing Haskell files. A directory will be searched recursively for any files ending with `.hs` or `.lhs`. For example, running HLint over darcs would give:
+```console
+$ hlint darcs-2.1.2
- $ hlint darcs-2.1.2
+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:94:1: Warning: Use concatMap
- Found:
- concat $ map escapeC s
- Why not:
- concatMap escapeC s
+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\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: Warning: Use a more efficient monadic variant
+Found:
+ mapM (delete_line (fn2fp f) line) old
+Why not:
+ mapM_ (delete_line (fn2fp f) line) old
- 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 hints ...
+... lots more hints ...
+```
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`.
@@ -56,21 +53,33 @@ The first hint is marked as an warning, because using `concatMap` in preference
**Bug reports:** The suggested replacement should be equivalent - please report all incorrect suggestions not mentioned as known limitations.
-### Running with Continuous Integration
+### Suggested usage
-Before running HLint on your continuous integration (CI) server, you should first ensure there are no existing hints. One way to achieve that is to ignore existing hints by running `hlint . --default > .hlint.yaml` and checking in the resulting `.hlint.yaml`.
+HLint usage tends to proceed in three distinct phases:
+
+1. Initially, run `hlint . --report` to generate `report.html` containing a list of all issues HLint has found. Fix those you think are worth fixing and keep repeating.
+1. Once you are happy, run `hlint . --default > .hlint.yaml`, which will generate a settings file ignoring all the hints currently outstanding. Over time you may wish to edit the list.
+1. For larger projects, add [custom hints or rules](#customizing-the-hints).
+
+Most hints are intended to be a good idea in most circumstances, but not universally - judgement is required. When contributing to someone else's project, HLint can identify pieces of code to look at, but only make changes you consider improvements - not merely to adhere to HLint rules.
+
+### Running with Continuous Integration
On the CI you should then run `hlint .` (or `hlint src` if you only want to check the `src` directory). To avoid the cost of compilation you may wish to fetch the [latest HLint binary release](https://github.com/ndmitchell/hlint/releases/latest). For certain CI environments there are helper scripts to do that.
**Travis:** Execute the following command:
- curl -sL https://raw.github.com/ndmitchell/hlint/master/misc/travis.sh | sh -s .
+```sh
+curl -sL https://raw.github.com/ndmitchell/hlint/master/misc/travis.sh | sh -s .
+```
The arguments after `-s` are passed to `hlint`, so modify the final `.` if you want other arguments.
**Appveyor:** Add the following statement to `.appveyor.yml`:
- - ps: Invoke-Command ([Scriptblock]::Create((Invoke-WebRequest 'https://raw.githubusercontent.com/ndmitchell/hlint/master/misc/appveyor.ps1').Content)) -ArgumentList @('.')
+```powershell
+- ps: Invoke-Command ([Scriptblock]::Create((Invoke-WebRequest 'https://raw.githubusercontent.com/ndmitchell/hlint/master/misc/appveyor.ps1').Content)) -ArgumentList @('.')
+```
The arguments inside `@()` are passed to `hlint`, so add new arguments surrounded by `'`, space separated - e.g. `@('.' '--report')`.
@@ -118,10 +127,12 @@ HLint enables most Haskell extensions, disabling only those which steal too much
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 ()
- (local-set-key "\C-cl" 'hs-lint))
- (add-hook 'haskell-mode-hook 'my-haskell-mode-hook)
+```guile
+(require 'hs-lint)
+(defun my-haskell-mode-hook ()
+ (local-set-key "\C-cl" 'hs-lint))
+(add-hook 'haskell-mode-hook 'my-haskell-mode-hook)
+```
### GHCi Integration
@@ -146,7 +157,9 @@ HLint runs the [cpphs C preprocessor](http://hackage.haskell.org/package/cpphs)
Consider:
- foo xs = concat (map op xs)
+```haskell
+foo xs = concat (map op xs)
+```
This will suggest eta reduction to `concat . map op`, and then after making that change and running HLint again, will suggest use of `concatMap`. Many people wonder why HLint doesn't directly suggest `concatMap op`. There are a number of reasons:
@@ -174,8 +187,8 @@ HLint uses the `hlint.yaml` file it ships with by default (containing things lik
Most hints are perfect substitutions, and these are displayed without any notes. However, some hints change the semantics of your program - typically in irrelevant ways - but HLint shows a warning note. HLint does not warn when assuming typeclass laws (such as `==` being symmetric). Some notes you may see include:
* __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.
+* __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.
### What is the difference between error/warning/suggestion?
@@ -192,14 +205,15 @@ The difference between warning and suggestion is one of personal taste, typicall
Short answer: yes, it is!
If the language extension `OverloadedStrings` is enabled, `ghci` may however report error messages such as:
-```
+
+```console
Ambiguous type variable ‘t0’ arising from an annotation
prevents the constraint ‘(Data.Data.Data t0)’ from being solved.
```
In this case, a solution is to add the `:: String` type annotation. For example:
-```
+```haskell
{-# ANN someFunc ("HLint: ignore Use fmap" :: String) #-}
```
@@ -209,7 +223,9 @@ See discussion in [issue #372](https://github.com/ndmitchell/hlint/issues/372).
To customize the hints given by HLint, create a file `.hlint.yaml` in the root of your project. For a suitable default run:
- hlint --default > .hlint.yaml
+```console
+hlint --default > .hlint.yaml
+```
This default configuration contains lots of examples, including:
@@ -245,17 +261,21 @@ These directives are applied in the order they are given, with later hints overr
The hint suggesting `concatMap` can be defined as:
- - warn: {lhs: concat (map f x), rhs: concatMap f x}
+```yaml
+- warn: {lhs: concat (map f x), rhs: concatMap f x}
+```
This 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 `hlint.yaml` file in the data directory. This hint will automatically match `concat . map f` and `concat $ map f x`, so there is no need to give eta-reduced variants of the hints. Hints may tagged 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:
- $ hlint --find=src/Utils.hs
- -- hints found in src/Util.hs
- - warn: {lhs: "null (intersect a b)", rhs: "disjoint a b"}
- - warn: {lhs: "dropWhile isSpace", rhs: "trimStart"}
- - fixity: "infixr 5 !:"
+```console
+$ hlint --find=src/Utils.hs
+-- hints found in src/Util.hs
+- warn: {lhs: "null (intersect a b)", rhs: "disjoint a b"}
+- warn: {lhs: "dropWhile isSpace", rhs: "trimStart"}
+- fixity: "infixr 5 !:"
+```
These hints are suitable for inclusion in a custom hint file. You can also include Haskell fixity declarations in a hint file, and these will also be extracted. If you pass only `--find` flags then the hints will be written out, if you also pass files/folders to check, then the found hints will be automatically used when checking.
@@ -282,3 +302,7 @@ zip [1..length x] x -- ??? @Warning
```
The general syntax is `lhs -- rhs` with `lhs` being the expression you expect to be rewritten as `rhs`. The absence of `rhs` means you expect no hints to fire. In addition `???` lets you assert a warning without a particular suggestion, while `@` tags require a specific severity -- both these features are used less commonly.
+
+### Acknowledgements
+
+This program has only been made possible by the presence of the [haskell-src-exts](https://github.com/haskell-suite/haskell-src-exts) package, and many improvements have been made by [Niklas Broberg](http://www.nbroberg.se) in response to feature requests. Additionally, many people have provided help and patches, including Lennart Augustsson, Malcolm Wallace, Henk-Jan van Tuyl, Gwern Branwen, Alex Ott, Andy Stewart, Roman Leshchinskiy, Johannes Lippmann, Iustin Pop, Steve Purcell, Mitchell Rosen and others.
diff --git a/hlint.cabal b/hlint.cabal
index 2eddc8f..40945ef 100644
--- a/hlint.cabal
+++ b/hlint.cabal
@@ -1,13 +1,13 @@
cabal-version: >= 1.18
build-type: Simple
name: hlint
-version: 2.0.12
+version: 2.0.13
license: BSD3
license-file: LICENSE
category: Development
author: Neil Mitchell <ndmitchell@gmail.com>
maintainer: Neil Mitchell <ndmitchell@gmail.com>
-copyright: Neil Mitchell 2006-2017
+copyright: Neil Mitchell 2006-2018
synopsis: Source code suggestions
description:
HLint gives suggestions on how to improve your source code.
@@ -63,6 +63,8 @@ library
build-depends: hscolour >= 1.21
else
cpp-options: -DGPL_SCARES_ME
+ if impl(ghc < 8.0)
+ build-depends: semigroups >= 0.18
hs-source-dirs: src
exposed-modules:
diff --git a/src/Apply.hs b/src/Apply.hs
index 8d5e141..aaaf406 100644
--- a/src/Apply.hs
+++ b/src/Apply.hs
@@ -71,10 +71,8 @@ parseModuleApply flags s file src = do
res <- parseModuleEx (parseFlagsAddFixities [x | Infix x <- s] flags) file src
case res of
Right m -> return $ Right m
- Left (ParseError sl msg ctxt) -> do
- i <- return $ rawIdeaN Error "Parse error" (mkSrcSpan sl sl) ctxt Nothing []
- i <- return $ classify [x | SettingClassify x <- s] i
- return $ Left i
+ Left (ParseError sl msg ctxt) ->
+ return $ Left $ classify [x | SettingClassify x <- s] $ rawIdeaN Error "Parse error" (mkSrcSpan sl sl) ctxt Nothing []
-- | Find which hints a list of settings implies.
diff --git a/src/CmdLine.hs b/src/CmdLine.hs
index 8c3d530..921bd3f 100644
--- a/src/CmdLine.hs
+++ b/src/CmdLine.hs
@@ -195,7 +195,7 @@ mode = cmdArgsMode $ modes
,CmdHSE
{} &= explicit &= name "hse"
] &= program "hlint" &= verbosity
- &= summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2017")
+ &= summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2018")
where
nam xs = nam_ xs &= name [head xs]
nam_ xs = def &= explicit &= name xs
diff --git a/src/Config/Yaml.hs b/src/Config/Yaml.hs
index 89f85ff..1936e09 100644
--- a/src/Config/Yaml.hs
+++ b/src/Config/Yaml.hs
@@ -20,7 +20,7 @@ import qualified Data.ByteString.Char8 as BS
import qualified Data.HashMap.Strict as Map
import HSE.All hiding (Rule, String)
import Data.Functor
-import Data.Monoid
+import Data.Semigroup
import Util
import Prelude
@@ -40,7 +40,7 @@ readFileConfigYaml file contents = do
---------------------------------------------------------------------
-- YAML DATA TYPE
-newtype ConfigYaml = ConfigYaml [ConfigItem] deriving (Monoid,Show)
+newtype ConfigYaml = ConfigYaml [ConfigItem] deriving (Semigroup,Monoid,Show)
data ConfigItem
= ConfigPackage Package
@@ -64,7 +64,7 @@ data Group = Group
---------------------------------------------------------------------
-- YAML PARSING LIBRARY
-data Val = Val
+data Val = Val
Value -- the actual value I'm focused on
[(String, Value)] -- the path of values I followed (for error messages)
diff --git a/src/HSE/Scope.hs b/src/HSE/Scope.hs
index 395f129..5a50df5 100644
--- a/src/HSE/Scope.hs
+++ b/src/HSE/Scope.hs
@@ -1,11 +1,11 @@
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ViewPatterns, GeneralizedNewtypeDeriving #-}
module HSE.Scope(
Scope, scopeCreate, scopeImports,
scopeMatch, scopeMove
) where
-import Data.Monoid
+import Data.Semigroup
import HSE.Type
import HSE.Util
import Data.List
@@ -34,11 +34,7 @@ if Data.List.head x ==> x, then that might match List too
-- Note that the 'mempty' 'Scope' is not equivalent to 'scopeCreate' on an empty module,
-- due to the implicit import of 'Prelude'.
newtype Scope = Scope [ImportDecl S]
- deriving Show
-
-instance Monoid Scope where
- mempty = Scope []
- mappend (Scope xs) (Scope ys) = Scope $ xs ++ ys
+ deriving (Show, Monoid, Semigroup)
-- | Create a 'Scope' value from a module, based on the modules imports.
scopeCreate :: Module SrcSpanInfo -> Scope
diff --git a/src/HSE/Unify.hs b/src/HSE/Unify.hs
index 2fbb6c4..b961d89 100644
--- a/src/HSE/Unify.hs
+++ b/src/HSE/Unify.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module HSE.Unify(
Subst, fromSubst,
@@ -10,7 +11,7 @@ import Control.Applicative
import Data.List.Extra
import Data.Maybe
import Data.Data
-import Data.Monoid
+import Data.Semigroup
import Config.Type
import Hint.Type
import Control.Monad
@@ -25,6 +26,7 @@ import Prelude
-- | A list of substitutions. A key may be duplicated, you need to call 'check'
-- to ensure the substitution is valid.
newtype Subst a = Subst [(String, a)]
+ deriving (Semigroup, Monoid)
-- | Unpack the substitution
fromSubst :: Subst a -> [(String, a)]
@@ -36,10 +38,6 @@ instance Functor Subst where
instance Pretty a => Show (Subst a) where
show (Subst xs) = unlines [a ++ " = " ++ prettyPrint b | (a,b) <- xs]
-instance Monoid (Subst a) where
- mempty = Subst []
- mappend (Subst xs) (Subst ys) = Subst $ xs ++ ys
-
-- check the unification is valid and simplify it
validSubst :: (a -> a -> Bool) -> Subst a -> Maybe (Subst a)
diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs
index 61fe19a..3b03f64 100644
--- a/src/Hint/Bracket.hs
+++ b/src/Hint/Bracket.hs
@@ -54,6 +54,10 @@ foo = (case x of y -> z; q -> w) :: Int
-- backup fixity resolution
main = do a += b . c; return $ a . b
+-- <$> bracket tests
+yes = (foo . bar x) <$> baz q -- foo . bar x <$> baz q
+no = foo . bar x <$> baz q
+
-- annotations
main = 1; {-# ANN module ("HLint: ignore Use camelCase" :: String) #-}
main = 1; {-# ANN module (1 + (2)) #-} -- 2
@@ -137,15 +141,18 @@ dollar = concatMap f . universe
where
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"
- ]
-
+ ,let r = Replace Expr (toSS x) [("a", toSS a), ("b", toSS b)] "a b"]
++
[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
,not $ a1 ~= "select" -- special case for esqueleto, see #224
, let y = App an a1 (Paren an a2)
, let r = Replace Expr (toSS e) [("a", toSS a1), ("b", toSS a2)] "a (b)" ]
+ ++
+ -- special case of (v1 . v2) <$> v3
+ [suggest "Redundant bracket" x y []
+ | InfixApp _ (Paren _ o1@(InfixApp _ v1 (isDot -> True) v2)) o2 v3 <- [x], opExp o2 ~= "<$>"
+ , let y = InfixApp an o1 o2 v3]
-- return both sides, and a way to put them together again
diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs
index f143413..82cfdee 100644
--- a/src/Hint/Extensions.hs
+++ b/src/Hint/Extensions.hs
@@ -123,7 +123,7 @@ import Data.List.Extra
import Data.Ratio
import Data.Data
import Refact.Types
-import Data.Monoid
+import Data.Semigroup
import Prelude
@@ -244,10 +244,12 @@ data Derives = Derives
,derivesData :: [String]
,derivesStandalone :: [String]
}
+instance Semigroup Derives where
+ Derives x1 x2 x3 <> Derives y1 y2 y3 =
+ Derives (x1++y1) (x2++y2) (x3++y3)
instance Monoid Derives where
mempty = Derives [] [] []
- mappend (Derives x1 x2 x3) (Derives y1 y2 y3) =
- Derives (x1++y1) (x2++y2) (x3++y3)
+ mappend = (<>)
-- | What is derived on newtype, and on data type
-- 'deriving' declarations may be on either, so we approximate as both newtype and data
diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs
index e822c85..e090c33 100644
--- a/src/Hint/Monad.hs
+++ b/src/Hint/Monad.hs
@@ -20,6 +20,11 @@ yes = do bar; a <- foo; return a -- do bar; foo
no = do bar; a <- foo; return b
yes = do x <- bar; x -- do join bar
no = do x <- bar; x; x
+yes = do x <- bar; return (f x) -- do f <$> bar
+yes = do x <- bar; return $ f x -- do f <$> bar
+yes = do x <- bar; return $ f (g x) -- do f . g <$> bar
+yes = do x <- bar; return (f $ g x) -- do f . g <$> bar
+no = do x <- bar; return (f x x)
{-# LANGUAGE RecursiveDo #-}; no = mdo hook <- mkTrigger pat (act >> rmHook hook) ; return hook
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
@@ -63,6 +68,7 @@ monadExp decl (parent, x) = case x of
(view -> App2 op x1 (view -> LamConst1 _)) | op ~= ">>=" -> f x1
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 "Use fmap" x (Do an y) rs | Just (y, rs) <- [monadFmap xs]] ++
[warn "Redundant do" x y [Replace Expr (toSS x) [("y", toSS y)] "y"]
| [Qualifier _ y] <- [xs], not $ doOperator parent y] ++
[suggest "Use let" x (Do an y) rs | Just (y, rs) <- [monadLet xs]] ++
@@ -95,6 +101,17 @@ monadCall (replaceBranches -> (bs@(_:_), gen)) | all isJust res
monadCall x | x2:_ <- filter (x ~=) badFuncs = let x3 = x2 ++ "_" in Just (x3, toNamed x3, [Replace Expr (toSS x) [] x3])
monadCall _ = Nothing
+monadFmap :: [Stmt S] -> Maybe ([Stmt S], [Refactoring R.SrcSpan])
+monadFmap (reverse -> q@(Qualifier _ (let go (App _ f x) = first (f:) $ go (fromParen x)
+ go (InfixApp _ f (isDol -> True) x) = first (f:) $ go x
+ go x = ([], x)
+ in go -> (ret:f:fs, view -> Var_ v))):g@(Generator _ (view -> PVar_ u) x):rest)
+ | ret ~= "return", u == v, v `notElem` vars (f:fs)
+ = Just (reverse (Qualifier an (InfixApp an (foldl' (flip (InfixApp an) (toNamed ".")) f fs) (toNamed "<$>") x):rest),
+ [Replace Stmt (toSS g) (("x", toSS x):zip vs (toSS <$> f:fs)) (intercalate " . " vs ++ " <$> x"), Delete Stmt (toSS q)])
+ where vs = ('f':) . show <$> [0..]
+monadFmap _ = Nothing
+
monadReturn :: [Stmt S] -> Maybe ([Stmt S], [Refactoring R.SrcSpan])
monadReturn (reverse -> q@(Qualifier _ (App _ ret (Var _ v))):g@(Generator _ (PVar _ p) x):rest)
| ret ~= "return", fromNamed v == fromNamed p
diff --git a/src/Hint/Restrict.hs b/src/Hint/Restrict.hs
index 134127d..39acc34 100644
--- a/src/Hint/Restrict.hs
+++ b/src/Hint/Restrict.hs
@@ -17,7 +17,7 @@ import Config.Type
import Hint.Type
import Data.List
import Data.Maybe
-import Data.Monoid
+import Data.Semigroup
import Control.Applicative
import Prelude
@@ -39,9 +39,11 @@ data RestrictItem = RestrictItem
{riAs :: [String]
,riWithin :: [(String, String)]
}
+instance Semigroup RestrictItem where
+ RestrictItem x1 x2 <> RestrictItem y1 y2 = RestrictItem (x1<>y1) (x2<>y2)
instance Monoid RestrictItem where
mempty = RestrictItem [] []
- mappend (RestrictItem x1 x2) (RestrictItem y1 y2) = RestrictItem (x1<>y1) (x2<>y2)
+ mappend = (<>)
restrictions :: [Setting] -> Map.Map RestrictType (Bool, Map.Map String RestrictItem)
restrictions settings = Map.map f $ Map.fromListWith (++) [(restrictType x, [x]) | SettingRestrict x <- settings]
diff --git a/src/Hint/Type.hs b/src/Hint/Type.hs
index f67d2ac..9898b69 100644
--- a/src/Hint/Type.hs
+++ b/src/Hint/Type.hs
@@ -4,7 +4,7 @@ module Hint.Type(
module Export
) where
-import Data.Monoid
+import Data.Semigroup
import Config.Type
import HSE.All as Export
import Idea as Export
@@ -26,10 +26,13 @@ data Hint {- PUBLIC -} = Hint
,hintComment :: [Setting] -> Comment -> [Idea] -- ^ Given a comment generate some 'Idea's.
}
-instance Monoid Hint where
- mempty = Hint (\_ _ -> []) (\_ _ _ -> []) (\_ _ _ _ -> []) (\_ _ -> [])
- mappend (Hint x1 x2 x3 x4) (Hint y1 y2 y3 y4) = Hint
+instance Semigroup Hint where
+ Hint x1 x2 x3 x4 <> Hint y1 y2 y3 y4 = Hint
(\a b -> x1 a b ++ y1 a b)
(\a b c -> x2 a b c ++ y2 a b c)
(\a b c d -> x3 a b c d ++ y3 a b c d)
(\a b -> x4 a b ++ y4 a b)
+
+instance Monoid Hint where
+ mempty = Hint (\_ _ -> []) (\_ _ _ -> []) (\_ _ _ _ -> []) (\_ _ -> [])
+ mappend = (<>)
diff --git a/src/HsColour.hs b/src/HsColour.hs
index df9f159..8756051 100644
--- a/src/HsColour.hs
+++ b/src/HsColour.hs
@@ -11,15 +11,16 @@ hsColourHTML = id
#else
+import Data.Functor
+import Prelude
+
import Language.Haskell.HsColour.TTY as TTY
import Language.Haskell.HsColour.Colourise
import Language.Haskell.HsColour.CSS as CSS
hsColourConsole :: IO (String -> String)
-hsColourConsole = do
- prefs <- readColourPrefs
- return $ TTY.hscolour prefs
+hsColourConsole = TTY.hscolour <$> readColourPrefs
hsColourHTML :: String -> String
hsColourHTML = CSS.hscolour False 1
diff --git a/src/Idea.hs b/src/Idea.hs
index d865bd9..4af205e 100644
--- a/src/Idea.hs
+++ b/src/Idea.hs
@@ -9,6 +9,7 @@ module Idea(
Severity(..)
) where
+import Data.Functor
import Data.List.Extra
import Data.Char
import Numeric
@@ -17,6 +18,7 @@ import Config.Type
import HsColour
import Refact.Types hiding (SrcSpan)
import qualified Refact.Types as R
+import Prelude
-- | An idea suggest by a 'Hint'.
@@ -71,9 +73,7 @@ instance Show Idea where
showANSI :: IO (Idea -> String)
-showANSI = do
- f <- hsColourConsole
- return $ showEx f
+showANSI = showEx <$> hsColourConsole
showEx :: (String -> String) -> Idea -> String
showEx tt Idea{..} = unlines $
diff --git a/src/Language/Haskell/HLint3.hs b/src/Language/Haskell/HLint3.hs
index d4be610..588333a 100644
--- a/src/Language/Haskell/HLint3.hs
+++ b/src/Language/Haskell/HLint3.hs
@@ -42,6 +42,8 @@ import Paths_hlint
import Data.List.Extra
import Data.Maybe
import System.FilePath
+import Data.Functor
+import Prelude
-- | Get the Cabal configured data directory of HLint.
@@ -105,8 +107,7 @@ readSettingsFile dir x
findSettings :: (String -> IO (FilePath, Maybe String)) -> Maybe String -> IO ([Fixity], [Classify], [Either HintBuiltin HintRule])
findSettings load start = do
(file,contents) <- load $ fromMaybe "hlint.yaml" start
- xs <- readFilesConfig [(file,contents)]
- return $ splitSettings xs
+ splitSettings <$> readFilesConfig [(file,contents)]
-- | Split a list of 'Setting' for separate use in parsing and hint resolution
splitSettings :: [Setting] -> ([Fixity], [Classify], [Either HintBuiltin HintRule])
diff --git a/src/Test/Annotations.hs b/src/Test/Annotations.hs
index b2410d5..62a30c3 100644
--- a/src/Test/Annotations.hs
+++ b/src/Test/Annotations.hs
@@ -3,8 +3,10 @@
-- | Check the <TEST> annotations within source and hint files.
module Test.Annotations(testAnnotations) where
+import Control.Exception.Extra
import Data.Tuple.Extra
import Data.Char
+import Data.Either.Extra
import Data.List.Extra
import Data.Maybe
import Data.Function
@@ -14,6 +16,8 @@ import Idea
import Apply
import HSE.All
import Test.Util
+import Data.Functor
+import Prelude
-- Input, Output
@@ -27,18 +31,20 @@ testAnnotations setting file = do
mapM_ f tests
where
f (Test loc inp out) = do
- ideas <- applyHintFile defaultParseFlags setting file $ Just inp
- let good = case out of
- Nothing -> null ideas
- Just x -> length ideas == 1 &&
- seq (length (show ideas)) True && -- force, mainly for hpc
- match x (head ideas)
+ ideas <- try_ $ do
+ res <- applyHintFile defaultParseFlags setting file $ Just inp
+ evaluate $ length $ show res
+ return res
+ let good = case (out, ideas) of
+ (Nothing, Right []) -> True
+ (Just x, Right [idea]) | match x idea -> True
+ _ -> False
let bad =
[failed $
- ["TEST FAILURE (" ++ show (length ideas) ++ " hints generated)"
+ ["TEST FAILURE (" ++ show (either (const 1) length ideas) ++ " hints generated)"
,"SRC: " ++ showSrcLoc loc
,"INPUT: " ++ inp] ++
- map ((++) "OUTPUT: " . show) ideas ++
+ map ("OUTPUT: " ++) (either (return . show) (map show) ideas) ++
["WANTED: " ++ fromMaybe "<failure>" out]
| not good] ++
[failed
@@ -46,7 +52,7 @@ testAnnotations setting file = do
,"SRC: " ++ showSrcLoc loc
,"INPUT: " ++ inp
,"OUTPUT: " ++ show i]
- | i@Idea{..} <- ideas, let SrcLoc{..} = getPointLoc ideaSpan, srcFilename == "" || srcLine == 0 || srcColumn == 0]
+ | i@Idea{..} <- fromRight [] ideas, let SrcLoc{..} = getPointLoc ideaSpan, srcFilename == "" || srcLine == 0 || srcColumn == 0]
if null bad then passed else sequence_ bad
match "???" _ = True
@@ -59,10 +65,9 @@ testAnnotations setting file = do
parseTestFile :: FilePath -> IO [Test]
-parseTestFile file = do
- src <- readFile file
+parseTestFile file =
-- we remove all leading # symbols since Yaml only lets us do comments that way
- return $ f False $ zip [1..] $ map (\x -> fromMaybe x $ stripPrefix "# " x) $ lines src
+ f False . zip [1..] . map (\x -> fromMaybe x $ stripPrefix "# " x) . lines <$> readFile file
where
open = isPrefixOf "<TEST>"
shut = isPrefixOf "</TEST>"