diff --git a/CHANGES.txt b/CHANGES.txt --- 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 --- 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 --- a/README.md +++ b/README.md @@ -7,10 +7,6 @@ * [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 @@ 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: - - $ hlint darcs-2.1.2 +```console +$ 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 @@ **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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ ``` 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 --- 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 maintainer: Neil Mitchell -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 @@ 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 --- a/src/Apply.hs +++ b/src/Apply.hs @@ -71,10 +71,8 @@ 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 --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -195,7 +195,7 @@ ,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 --- a/src/Config/Yaml.hs +++ b/src/Config/Yaml.hs @@ -20,7 +20,7 @@ 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 @@ --------------------------------------------------------------------- -- 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 @@ --------------------------------------------------------------------- -- 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 --- 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 @@ -- 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 --- 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 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 @@ -- | 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)] @@ -35,10 +37,6 @@ 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 diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs --- a/src/Hint/Bracket.hs +++ b/src/Hint/Bracket.hs @@ -54,6 +54,10 @@ -- 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 @@ 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 --- a/src/Hint/Extensions.hs +++ b/src/Hint/Extensions.hs @@ -123,7 +123,7 @@ import Data.Ratio import Data.Data import Refact.Types -import Data.Monoid +import Data.Semigroup import Prelude @@ -244,10 +244,12 @@ ,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 --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -20,6 +20,11 @@ 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 @@ (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]] ++ @@ -94,6 +100,17 @@ rs = concatMap (\(Just (a,b,c)) -> c) 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) diff --git a/src/Hint/Restrict.hs b/src/Hint/Restrict.hs --- a/src/Hint/Restrict.hs +++ b/src/Hint/Restrict.hs @@ -17,7 +17,7 @@ import Hint.Type import Data.List import Data.Maybe -import Data.Monoid +import Data.Semigroup import Control.Applicative import Prelude @@ -39,9 +39,11 @@ {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 --- a/src/Hint/Type.hs +++ b/src/Hint/Type.hs @@ -4,7 +4,7 @@ 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 @@ ,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 --- a/src/HsColour.hs +++ b/src/HsColour.hs @@ -11,15 +11,16 @@ #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 --- a/src/Idea.hs +++ b/src/Idea.hs @@ -9,6 +9,7 @@ Severity(..) ) where +import Data.Functor import Data.List.Extra import Data.Char import Numeric @@ -17,6 +18,7 @@ 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 @@ 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 --- a/src/Language/Haskell/HLint3.hs +++ b/src/Language/Haskell/HLint3.hs @@ -42,6 +42,8 @@ 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 @@ 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 --- a/src/Test/Annotations.hs +++ b/src/Test/Annotations.hs @@ -3,8 +3,10 @@ -- | Check the 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 Apply import HSE.All import Test.Util +import Data.Functor +import Prelude -- Input, Output @@ -27,18 +31,20 @@ 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 "" out] | not good] ++ [failed @@ -46,7 +52,7 @@ ,"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 @@ 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 "" shut = isPrefixOf ""