packages feed

hlint 3.4 → 3.4.1

raw patch · 15 files changed

+331/−100 lines, 15 filesdep +deriving-aesondep ~aesondep ~ghc-lib-parser-ex

Dependencies added: deriving-aeson

Dependency ranges changed: aeson, ghc-lib-parser-ex

Files

.hlint.yaml view
@@ -5,6 +5,13 @@ # Hints that apply only to the HLint source code  #####################################################################+## GROUPS OF HINTS WE TURN ON++- group: {name: future, enabled: true}+- group: {name: extra, enabled: true}+++##################################################################### ## RESTRICTIONS  - extensions:@@ -17,6 +24,7 @@   - name: [PackageImports]   - name: [ConstraintKinds, RankNTypes, TypeFamilies]   - name: [TemplateHaskell]+  - name: [DerivingVia, DeriveGeneric, DataKinds]   - {name: CPP, within: [HsColour, Config.Yaml, Test.Annotations]} # so it can be disabled to avoid GPL code  - flags:
CHANGES.txt view
@@ -1,5 +1,16 @@ Changelog for HLint (* = breaking change) +3.4.1, released 2022-07-10+    #1345, add --generate-config to generate a complete config+    #1345, add --generate-summary-json+    #1377, make anyM/allM on [] produce pure, rather than return+    #1377, add a pure rule for every return variant+    #1380, add counts as comments for --default+    #1372, remove unnecessary brackets when suggesting forM_+    #1372, suggest void (forM x y) to forM_ without the void+    #1394, replace maximum [a, b] ==> max a b (and for min)+    #1393, for QuickCheck, join . elements ==> oneOf+    #1387, bypass camelCase hint for new tasty_... custom test prefix 3.4, released 2022-04-24     #1360, make -XHaskell2010 still obey CPP pragmas     #1368, make TH quotation bracket rule off by default
README.md view
@@ -201,6 +201,25 @@  HLint uses the `hlint.yaml` file it ships with by default (containing things like the `concatMap` hint above), along with the first `.hlint.yaml` file it finds in the current directory or any parent thereof. To include other hints, pass `--hint=filename.yaml`. +#### Are there any extra hints available?++There are a few groups of hints that are shipped with HLint, but disabled by default. These are:++* `future`, which suggests switching `return` for `pure`.+* `extra`, which suggests replacements which introduce a dependency on the [`extra` library](https://hackage.haskell.org/package/extra).+* `use-lens`, which suggests replacements which introduce a dependency on the [`lens` library](https://hackage.haskell.org/package/lens).+* `use-th-quotes`, which suggests using `[| x |]` where possible.+* `generalise`, which suggests more generic methods, e.g. `fmap` instead of `map`.+* `generalise-for-conciseness`, which suggests more generic methods, but only when they are shorter, e.g. `maybe True` becomes `all`.+* `dollar` which suggests `a $ b $ c` is replaced with `a . b $ c`.+* `teaching` which encourages a simple beginner friendly style, learning about related functions.++These can be enabled by passing `--with-group=future` or adding the following to your `.hlint.yaml` file:++```yaml+- group: {name: future, enabled: true}+```+ ### Design  #### Why are hints not applied recursively?@@ -247,15 +266,21 @@ hlint --default > .hlint.yaml ``` -This default configuration contains lots of examples, including:+This default configuration shows lots of examples (as `# comments`) of how to: -* Adding command line arguments to all runs, e.g. `--color` or `-XNoMagicHash`.-* Ignoring certain hints, perhaps within certain modules/functions.-* Restricting use of GHC flags/extensions/functions, e.g. banning `Arrows` and `unsafePerformIO`.-* Adding additional project-specific hints.+* Add command line arguments to all runs, e.g. `--color` or `-XNoMagicHash`.+* Ignore certain hints, perhaps within certain modules/functions.+* Restrict the use of GHC flags/extensions/functions, e.g. banning `Arrows` and `unsafePerformIO`.+* Add additional project-specific hints. -You can see the output of `--default` [here](https://github.com/ndmitchell/hlint/blob/master/data/default.yaml).+You can see the output of `--default` for a clean lint [here](https://github.com/ndmitchell/hlint/blob/master/data/default.yaml) but for a dirty project `--default` output includes an extra warnings section that counts and ignores any hints it finds: +  ```yaml+  # Warnings currently triggered by your code+  - ignore: {name: "Redundant $"} # 20 hints+  - ignore: {name: "Unused LANGUAGE pragma"} # 29 hints+  ```+ If you wish to use the [Dhall configuration language](https://github.com/dhall-lang/dhall-lang) to customize HLint, there [is an example](https://kowainik.github.io/posts/2018-09-09-dhall-to-hlint) and [type definition](https://github.com/kowainik/relude/blob/master/hlint/Rule.dhall).  ### Finding the name of a hint@@ -355,7 +380,9 @@   - {name: unsafePerformIO, within: CompatLayer} ``` -This declares that the `nub` function can't be used in any modules, and thus is banned from the code. That's probably a good idea, as most people should use an alternative that isn't _O(n^2)_ (e.g. [`nubOrd`](https://hackage.haskell.org/package/extra/docs/Data-List-Extra.html#v:nubOrd)). We also whitelist where `unsafePerformIO` can occur, ensuring that there can be a centrally reviewed location to declare all such instances. Finally, we can restrict the use of modules with:+This declares that the `nub` function can't be used in any modules, and thus is banned from the code. That's probably a good idea, as most people should use an alternative that isn't _O(n^2)_ (e.g. [`nubOrd`](https://hackage.haskell.org/package/extra/docs/Data-List-Extra.html#v:nubOrd)). We also whitelist where `unsafePerformIO` can occur, ensuring that there can be a centrally reviewed location to declare all such instances. Function names can be given qualified, e.g. `Data.List.head`, but note that functions available through multiple exports (e.g. `head` is also available from `Prelude`) should be listed through all paths they are likely to be obtained, as the HLint qualified matching is unaware of re-exports.++Finally, we can restrict the use of modules with:  ```yaml - modules:
data/hlint.yaml view
@@ -52,6 +52,11 @@     - import Data.Attoparsec.ByteString  - package:+    name: quickcheck+    modules:+    - import Test.QuickCheck++- package:     name: codeworld-api     modules:     - import CodeWorld@@ -118,6 +123,8 @@     - warn: {lhs: if a > b then a else b, rhs: max a b}     - warn: {lhs: if a <= b then a else b, rhs: min a b}     - warn: {lhs: if a < b then a else b, rhs: min a b}+    - warn: {lhs: "maximum [a, b]", rhs: max a b}+    - warn: {lhs: "minimum [a, b]", rhs: min a b}       # READ/SHOW@@ -289,6 +296,7 @@      # FOLDS +    - warn: {lhs: foldr  (>>) (pure ()), rhs: sequence_}     - warn: {lhs: foldr  (>>) (return ()), rhs: sequence_}     - warn: {lhs: foldr  (&&) True, rhs: and}     - warn: {lhs: foldl  (&&) True, rhs: and, note: IncreasesLaziness}@@ -439,20 +447,28 @@      # APPLICATIVE -    - hint: {lhs: return x <*> y, rhs: x <$> y}     - hint: {lhs: pure x <*> y, rhs: x <$> y}+    - hint: {lhs: return x <*> y, rhs: x <$> y}     - warn: {lhs: x <* pure y, rhs: x}+    - warn: {lhs: x <* return y, rhs: x}     - warn: {lhs: pure x *> y, rhs: "y"}+    - warn: {lhs: return x *> y, rhs: "y"}      # MONAD +    - warn: {lhs: pure a >>= f, rhs: f a, name: "Monad law, left identity"}     - warn: {lhs: return a >>= f, rhs: f a, name: "Monad law, left identity"}+    - warn: {lhs: f =<< pure a, rhs: f a, name: "Monad law, left identity"}     - warn: {lhs: f =<< return a, rhs: f a, name: "Monad law, left identity"}+    - warn: {lhs: m >>= pure, rhs: m, name: "Monad law, right identity"}     - warn: {lhs: m >>= return, rhs: m, name: "Monad law, right identity"}+    - warn: {lhs: pure =<< m, rhs: m, name: "Monad law, right identity"}     - warn: {lhs: return =<< m, rhs: m, name: "Monad law, right identity"}     - warn: {lhs: liftM, rhs: fmap}     - warn: {lhs: liftA, rhs: fmap}+    - hint: {lhs: m >>= pure . f, rhs: m Data.Functor.<&> f}     - hint: {lhs: m >>= return . f, rhs: m Data.Functor.<&> f}+    - hint: {lhs: pure . f =<< m, rhs: f <$> m}     - hint: {lhs: return . f =<< m, rhs: f <$> m}     - warn: {lhs: fmap f x >>= g, rhs: x >>= g . f}     - warn: {lhs: f <$> x >>= g, rhs: x >>= g . f}@@ -460,9 +476,13 @@     - warn: {lhs: g =<< fmap f x, rhs: g . f =<< x}     - warn: {lhs: g =<< f <$> x, rhs: g . f =<< x}     - warn: {lhs: g =<< (x Data.Functor.<&> f), rhs: g . f =<< x}+    - warn: {lhs: if x then y else pure (), rhs: Control.Monad.when x $ _noParen_ y, side: not (isAtom y)}     - warn: {lhs: if x then y else return (), rhs: Control.Monad.when x $ _noParen_ y, side: not (isAtom y)}+    - warn: {lhs: if x then y else pure (), rhs: Control.Monad.when x y, side: isAtom y}     - warn: {lhs: if x then y else return (), rhs: Control.Monad.when x y, side: isAtom y}+    - warn: {lhs: if x then pure () else y, rhs: Control.Monad.unless x $ _noParen_ y, side: isAtom y}     - warn: {lhs: if x then return () else y, rhs: Control.Monad.unless x $ _noParen_ y, side: isAtom y}+    - warn: {lhs: if x then pure () else y, rhs: Control.Monad.unless x y, side: isAtom y}     - warn: {lhs: if x then return () else y, rhs: Control.Monad.unless x y, side: isAtom y}     - warn: {lhs: sequence (map f x), rhs: mapM f x}     - warn: {lhs: sequence_ (map f x), rhs: mapM_ f x}@@ -482,6 +502,7 @@     - warn: {lhs: id =<< x, rhs: Control.Monad.join x}     - hint: {lhs: join (f <$> x), rhs: f =<< x}     - hint: {lhs: join (fmap f x), rhs: f =<< x}+    - hint: {lhs: a >> pure (), rhs: Control.Monad.void a, side: isAtom a || isApp a}     - hint: {lhs: a >> return (), rhs: Control.Monad.void a, side: isAtom a || isApp a}     - warn: {lhs: fmap (const ()), rhs: Control.Monad.void}     - warn: {lhs: const () <$> x, rhs: Control.Monad.void x}@@ -496,16 +517,21 @@     - hint: {lhs: (f =<<) . g, rhs: f Control.Monad.<=< g}     - warn: {lhs: a >> forever a, rhs: forever a}     - hint: {lhs: liftM2 id, rhs: ap}+    - warn: {lhs: liftM2 f (pure x), rhs: fmap (f x)}     - warn: {lhs: liftA2 f (return x), rhs: fmap (f x)}     - warn: {lhs: liftM2 f (pure x), rhs: fmap (f x)}     - warn: {lhs: liftM2 f (return x), rhs: fmap (f x)}+    - warn: {lhs: fmap f (pure x), rhs: pure (f x)}     - warn: {lhs: fmap f (return x), rhs: return (f x)}+    - warn: {lhs: f <$> pure x, rhs: pure (f x)}     - warn: {lhs: f <$> return x, rhs: return (f x)}     - warn: {lhs: mapM (uncurry f) (zip l m), rhs: zipWithM f l m}     - warn: {lhs: mapM_ (void . f), rhs: mapM_ f}     - warn: {lhs: forM_ x (void . f), rhs: forM_ x f}     - warn: {lhs: a >>= \_ -> b, rhs: a >> b}+    - warn: {lhs: m <* pure x, rhs: m}     - warn: {lhs: m <* return x, rhs: m}+    - warn: {lhs: pure x *> m, rhs: m}     - warn: {lhs: return x *> m, rhs: m}     - warn: {lhs: pure x >> m, rhs: m}     - warn: {lhs: return x >> m, rhs: m}@@ -543,14 +569,13 @@     - warn: {lhs: flip traverse_, rhs: for_}     - warn: {lhs: flip for_, rhs: traverse_}     - warn: {lhs: foldr (*>) (pure ()), rhs: sequenceA_}+    - warn: {lhs: foldr (*>) (return ()), rhs: sequenceA_}     - warn: {lhs: foldr (<|>) empty, rhs: asum}     - warn: {lhs: liftA2 (flip ($)), rhs: (<**>)}     - warn: {lhs: liftA2 f (pure x), rhs: fmap (f x)}-    - warn: {lhs: fmap f (pure x), rhs: pure (f x)}-    - warn: {lhs: f <$> pure x, rhs: pure (f x)}+    - warn: {lhs: liftA2 f (return x), rhs: fmap (f x)}     - warn: {lhs: Just <$> a <|> pure Nothing, rhs: optional a}-    - hint: {lhs: m >>= pure . f, rhs: m Data.Functor.<&> f}-    - hint: {lhs: pure . f =<< m, rhs: f <$> m}+    - warn: {lhs: Just <$> a <|> return Nothing, rhs: optional a}     - warn: {lhs: empty <|> x, rhs: x, name: "Alternative law, left identity"}     - warn: {lhs: x <|> empty, rhs: x, name: "Alternative law, right identity"}     - warn: {lhs: traverse id, rhs: sequenceA}@@ -746,8 +771,11 @@      # FOLDABLE +    - warn: {lhs: case m of Nothing -> pure (); Just x -> f x, rhs: Data.Foldable.forM_ m f}     - warn: {lhs: case m of Nothing -> return (); Just x -> f x, rhs: Data.Foldable.forM_ m f}+    - warn: {lhs: case m of Just x -> f x; Nothing -> pure (), rhs: Data.Foldable.forM_ m f}     - warn: {lhs: case m of Just x -> f x; Nothing -> return (), rhs: Data.Foldable.forM_ m f}+    - warn: {lhs: case m of Just x -> f x; _ -> pure (), rhs: Data.Foldable.forM_ m f}     - warn: {lhs: case m of Just x -> f x; _ -> return (), rhs: Data.Foldable.forM_ m f}     - warn: {lhs: when (isJust m) (f (fromJust m)), rhs: Data.Foldable.forM_ m f} @@ -915,6 +943,15 @@     - warn: {lhs: Data.Attoparsec.ByteString.option Nothing (Just <$> p), rhs: optional p}  - group:+    name: quickcheck+    enabled: true+    imports:+    - package base+    - package quickcheck+    rules:+    - warn: {lhs: Control.Monad.join (Test.QuickCheck.elements l), rhs: Test.QuickCheck.oneof l}++- group:     name: generalise     enabled: false     imports:@@ -979,20 +1016,24 @@     - warn: {lhs: "maybeM a pure x", rhs: "fromMaybeM a b"}     - warn: {lhs: "maybeM a return x", rhs: "fromMaybeM a b"}     - warn: {lhs: "either a b =<< c", rhs: "eitherM a b c"}-    - warn: {lhs: "fold1M a b >> return ()", rhs: "fold1M_ a b"}     - warn: {lhs: "fold1M a b >> pure ()", rhs: "fold1M_ a b"}+    - warn: {lhs: "fold1M a b >> return ()", rhs: "fold1M_ a b"}     - warn: {lhs: "flip concatMapM", rhs: "concatForM"}     - warn: {lhs: "liftM mconcat (mapM a b)", rhs: "mconcatMapM a b"}+    - warn: {lhs: "ifM a b (pure ())", rhs: "whenM a b"}     - warn: {lhs: "ifM a b (return ())", rhs: "whenM a b"}+    - warn: {lhs: "ifM a (pure ()) b", rhs: "unlessM a b"}     - warn: {lhs: "ifM a (return ()) b", rhs: "unlessM a b"}+    - warn: {lhs: "ifM a (pure True) b", rhs: "(||^) a b"}     - warn: {lhs: "ifM a (return True) b", rhs: "(||^) a b"}+    - warn: {lhs: "ifM a b (pure False)", rhs: "(&&^) a b"}     - warn: {lhs: "ifM a b (return False)", rhs: "(&&^) a b"}     - warn: {lhs: "anyM id", rhs: "orM"}     - warn: {lhs: "allM id", rhs: "andM"}     - warn: {lhs: "allM f [a]", rhs: f a, name: Evaluate}-    - warn: {lhs: "allM f []", rhs: return True, name: Evaluate}+    - warn: {lhs: "allM f []", rhs: pure True, name: Evaluate}     - warn: {lhs: "anyM f [a]", rhs: f a, name: Evaluate}-    - warn: {lhs: "anyM f []", rhs: return False, name: Evaluate}+    - warn: {lhs: "anyM f []", rhs: pure False, name: Evaluate}     - warn: {lhs: "either id id", rhs: "fromEither"}     - warn: {lhs: "either (const Nothing) Just", rhs: "eitherToMaybe"}     - warn: {lhs: "either (Left . a) Right", rhs: "mapLeft a"}
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version:      1.18 build-type:         Simple name:               hlint-version:            3.4+version:            3.4.1 license:            BSD3 license-file:       LICENSE category:           Development@@ -77,7 +77,8 @@         ansi-terminal >= 0.8.1,         extra >= 1.7.3,         refact >= 0.3,-        aeson >= 1.1.2.0,+        aeson >= 1.3,+        deriving-aeson >= 0.2,         filepattern >= 0.1.1      if !flag(ghc-lib) && impl(ghc >= 9.2.2) && impl(ghc < 9.3.0)
src/CmdLine.hs view
@@ -39,6 +39,7 @@ import Paths_hlint import Data.Version import Prelude+import Config.Type (Severity (Warning))   getCmd :: [String] -> IO Cmd@@ -125,7 +126,9 @@         ,cmdRefactorOptions :: String   -- ^ Options to pass to the `refactor` executable.         ,cmdWithRefactor :: FilePath    -- ^ Path to refactor tool         ,cmdIgnoreGlob :: [FilePattern]-        ,cmdGenerateSummary :: [FilePath]  -- ^ Generate a summary of available hints+        ,cmdGenerateMdSummary :: [FilePath]  -- ^ Generate a summary of available hints, in Markdown format+        ,cmdGenerateJsonSummary :: [FilePath]  -- ^ Generate a summary of built-in hints, in JSON format+        ,cmdGenerateExhaustiveConf :: [Severity]  -- ^ Generate a hlint config file with all built-in hints set to the specified level         ,cmdTest :: Bool         }     deriving (Data,Typeable,Show)@@ -164,7 +167,9 @@         ,cmdRefactorOptions = nam_ "refactor-options" &= typ "OPTIONS" &= help "Options to pass to the `refactor` executable"         ,cmdWithRefactor = nam_ "with-refactor" &= help "Give the path to refactor"         ,cmdIgnoreGlob = nam_ "ignore-glob" &= help "Ignore paths matching glob pattern (e.g. foo/bar/*.hs)"-        ,cmdGenerateSummary = nam_ "generate-summary" &= opt "hints.md" &= help "Generate a summary of built-in hints"+        ,cmdGenerateMdSummary = nam_ "generate-summary" &= opt "hints.md" &= help "Generate a summary of available hints, in Mardown format"+        ,cmdGenerateJsonSummary = nam_ "generate-summary-json" &= opt "hints.json" &= help "Generate a summary of available hints, in JSON format"+        ,cmdGenerateExhaustiveConf = nam_ "generate-config" &= opt Warning &= typ "LEVEL" &= help "Generate a .hlint.yaml config file with all hints set to the specified severity level (default level: warn, alternatives: ignore, suggest, error)"         ,cmdTest = nam_ "test" &= help "Run the test suite"         } &= auto &= explicit &= name "lint"         &= details ["HLint gives hints on how to improve Haskell code."@@ -188,7 +193,10 @@         fail $ unlines $ "Failed to find requested hint files:" : map ("  "++) bad      -- if the user has given any explicit hints, ignore the local ones-    implicit <- if explicit /= [] || cmdGenerateSummary cmd /= [] then pure Nothing else do+    implicit <- if explicit /= []+                  || cmdGenerateMdSummary cmd /= []+                  || cmdGenerateJsonSummary cmd /= []+                  || cmdGenerateExhaustiveConf cmd /= [] then pure Nothing else do         -- we follow the stylish-haskell config file search policy         -- 1) current directory or its ancestors; 2) home directory         curdir <- getCurrentDirectory
src/Config/Type.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}  module Config.Type(     Severity(..), Classify(..), HintRule(..), Note(..), Setting(..),@@ -16,6 +22,9 @@ import Fixity import GHC.Util import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances+import Deriving.Aeson+import System.Console.CmdArgs.Implicit+import Data.Aeson hiding (Error)  getSeverity :: String -> Maybe Severity getSeverity "ignore" = Just Ignore@@ -44,7 +53,8 @@     | 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. Only parse errors have this setting by default.-      deriving (Eq,Ord,Show,Read,Bounded,Enum)+      deriving (Eq,Ord,Show,Read,Bounded,Enum,Generic,Data)+      deriving (ToJSON) via CustomJSON '[FieldLabelModifier CamelToSnake] Severity   -- Any 1-letter variable names are assumed to be unification variables@@ -105,6 +115,13 @@     ,hintRuleSide :: Maybe (HsExtendInstances (GHC.Hs.LHsExpr GHC.Hs.GhcPs))  -- ^ Side condition (GHC parse tree).     }     deriving Show++instance ToJSON HintRule where+    toJSON HintRule{..} = object+        [ "name" .= hintRuleName+        , "lhs" .= show hintRuleLHS+        , "rhs" .= show hintRuleRHS+        ]  data RestrictType = RestrictModule | RestrictExtension | RestrictFlag | RestrictFunction deriving (Show,Eq,Ord)
src/EmbedData.hs view
@@ -10,11 +10,16 @@ import Data.ByteString.UTF8 import Data.FileEmbed +-- Use NOINLINE below to avoid dirtying too much when these files change++{-# NOINLINE hlintYaml #-} hlintYaml :: (FilePath, Maybe String) hlintYaml = ("data/hlint.yaml", Just $ toString $(embedFile "data/hlint.yaml")) +{-# NOINLINE defaultYaml #-} defaultYaml :: String defaultYaml = toString $(embedFile "data/default.yaml") +{-# NOINLINE reportTemplate #-} reportTemplate :: String reportTemplate = toString $(embedFile "data/report_template.html")
src/HLint.hs view
@@ -81,18 +81,36 @@     | cmdDefault = do         ideas <- if null cmdFiles then pure [] else withVerbosity Quiet $             runHlintMain args cmd{cmdJson=False,cmdSerialise=False,cmdRefactor=False} Nothing-        let bad = nubOrd $ map ideaHint ideas+        let bad = group $ sort $ map ideaHint ideas         if null bad then putStr defaultYaml else do             let group1:groups = splitOn ["",""] $ lines defaultYaml             let group2 = "# Warnings currently triggered by your code" :-                         ["- ignore: {name: " ++ show x ++ "}" | x <- bad]+                         ["- ignore: {name: " ++ show x ++ "} # "+                         ++ if null tl then "1 hint" else show (length xs) ++ " hints"+                         | xs@(x : tl) <- bad+                         ]+             putStr $ unlines $ intercalate ["",""] $ group1:group2:groups         pure []-    | cmdGenerateSummary /= [] = do-        forM_ cmdGenerateSummary $ \file -> timedIO "Summary" file $ do-            whenNormal $ putStrLn $ "Writing summary to " ++ file ++ " ..."-            summary <- generateSummary . snd =<< readAllSettings args cmd+    | cmdGenerateMdSummary /= [] = do+        forM_ cmdGenerateMdSummary $ \file -> timedIO "Summary" file $ do+            whenNormal $ putStrLn $ "Writing Markdown summary to " ++ file ++ " ..."+            summary <- generateMdSummary . snd =<< readAllSettings args cmd             writeFileBinary file summary+        pure []+    | cmdGenerateJsonSummary /= [] = do+        forM_ cmdGenerateJsonSummary $ \file -> timedIO "Summary" file $ do+            whenNormal $ putStrLn $ "Writing JSON summary to " ++ file ++ " ..."+            summary <- generateJsonSummary . snd =<< readAllSettings args cmd+            writeFileBinary file summary+        pure []+    | cmdGenerateExhaustiveConf /= [] = do+        forM_ cmdGenerateExhaustiveConf $ \severity ->+            let file = show severity ++ "-all.yaml"+             in timedIO "Exhaustive config file" file $ do+                whenNormal $ putStrLn $ "Writing " ++ show severity ++ "-all list to " ++ file ++ " ..."+                exhaustiveConfig <- generateExhaustiveConfig severity . snd =<< readAllSettings args cmd+                writeFileBinary file exhaustiveConfig         pure []     | null cmdFiles && not (null cmdFindHints) = do         hints <- concatMapM (resolveFile cmd Nothing) cmdFindHints
src/Hint/Monad.hs view
@@ -1,4 +1,10 @@-{-# LANGUAGE LambdaCase, ViewPatterns, PatternGuards, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+ {-     Find and match: @@ -45,7 +51,9 @@ main = do f a $ sleep 10 -- @Ignore main = do foo x; return 3; bar z -- main = void $ forM_ f xs -- forM_ f xs-main = void $ forM f xs -- void $ forM_ f xs+main = void (forM_ f xs) -- forM_ f xs+main = void $ forM f xs -- forM_ f xs+main = void (forM f xs) -- forM_ f xs main = do _ <- forM_ f xs; bar -- forM_ f xs main = do bar; forM_ f xs; return () -- do bar; forM_ f xs main = do a; when b c; return () -- do a; when b c@@ -125,8 +133,27 @@     _ -> []   where     f = monadNoResult (fromMaybe "" decl) id-    seenVoid wrap x = monadNoResult (fromMaybe "" decl) wrap x-      ++ [warn "Redundant void" (reLoc (wrap x)) (reLoc x) [Replace Expr (toSSA (wrap x)) [("a", toSSA x)] "a"] | returnsUnit x]+    seenVoid wrap (L l (HsPar x y)) = seenVoid (wrap . L l . HsPar x) y+    seenVoid wrap x =+      -- Suggest `traverse_ f x` given `void $ traverse_ f x`+      [warn "Redundant void" (reLoc (wrap x)) (reLoc x) [Replace Expr (toSSA (wrap x)) [("a", toSSA x)] "a"] | returnsUnit x]+        -- Suggest `traverse_ f x` given `void $ traverse f x`+        ++ ( case modifyAppHead+               ( \fun@(L l name) ->+                   ( if occNameStr name `elem` badFuncs+                       then L l (mkRdrUnqual (mkVarOcc (occNameStr name ++ "_")))+                       else fun,+                     fun+                   )+               )+               x of+               (x', Just fun@(L l name)) | occNameStr name `elem` badFuncs ->+                  let fun_ = occNameStr name ++ "_"+                   in [warn ("Use " ++ fun_) (reLoc (wrap x)) (reLoc x')+                        [Replace Expr (toSSA (wrap x)) [("a", toSSA x)] "a",+                         Replace Expr (toSSA fun) [] fun_]]+               _ -> []+           )     doSpan doOrMDo = \case       UnhelpfulSpan s -> UnhelpfulSpan s       RealSrcSpan s _ ->@@ -154,13 +181,23 @@     = srcSpanStartCol a == srcSpanStartCol b doAsAvoidingIndentation parent self = False +-- Apply a function to the application head, including `head arg` and `head $ arg`, which modifies+-- the head and returns a value. Sees through parentheses.+modifyAppHead :: forall a. (LIdP GhcPs -> (LIdP GhcPs, a)) -> LHsExpr GhcPs -> (LHsExpr GhcPs, Maybe a)+modifyAppHead f = go id+  where+    go :: (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> (LHsExpr GhcPs, Maybe a)+    go wrap (L l (HsPar _ x)) = go (wrap . L l . HsPar EpAnnNotUsed) x+    go wrap (L l (HsApp _ x y)) = go (\x -> wrap $ L l (HsApp EpAnnNotUsed x y)) x+    go wrap (L l (OpApp _ x op y)) | isDol op = go (\x -> wrap $ L l (OpApp EpAnnNotUsed x op y)) x+    go wrap (L l (HsVar _ x)) = (wrap (L l (HsVar NoExtField x')), Just a)+      where (x', a) = f x+    go _ expr = (expr, Nothing)  returnsUnit :: LHsExpr GhcPs -> Bool-returnsUnit (L _ (HsPar _ x)) = returnsUnit x-returnsUnit (L _ (HsApp _ x _)) = returnsUnit x-returnsUnit (L _ (OpApp _ x op _)) | isDol op = returnsUnit x-returnsUnit (L _ (HsVar _ (L _ x))) = occNameStr x `elem` map (++ "_") badFuncs ++ unitFuncs-returnsUnit _ = False+returnsUnit = fromMaybe False+            . snd+            . modifyAppHead (\x -> (x, occNameStr (unLoc x) `elem` map (++ "_") badFuncs ++ unitFuncs))  -- See through HsPar, and down HsIf/HsCase, return the name to use in -- the hint, and the revised expression.
src/Hint/Naming.hs view
@@ -122,7 +122,7 @@ suggestName :: String -> Maybe String suggestName original     | isSym original || good || not (any isLower original) || any isDigit original ||-        any (`isPrefixOf` original) ["prop_","case_","unit_","test_","spec_","scprop_","hprop_"] = Nothing+        any (`isPrefixOf` original) ["prop_","case_","unit_","test_","spec_","scprop_","hprop_","tasty_"] = Nothing     | otherwise = Just $ f original     where         good = all isAlphaNum $ drp '_' $ drp '#' $ reverse $ filter (/= '\'') $ drp '_' original
src/Summary.hs view
@@ -1,6 +1,9 @@-{-# LANGUAGE RecordWildCards, TupleSections #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DataKinds #-} -module Summary (generateSummary) where+module Summary (generateMdSummary, generateJsonSummary, generateExhaustiveConfig) where  import qualified Data.Map as Map import Control.Monad.Extra@@ -14,73 +17,127 @@ import Hint.All import Config.Type import Test.Annotations---data BuiltinKey = BuiltinKey-  { builtinName :: !String-  , builtinSeverity :: !Severity-  , builtinRefactoring :: !Bool-  } deriving (Eq, Ord)+import Deriving.Aeson+import Data.Aeson (encode)+import Data.ByteString.Char8 (unpack)+import Data.ByteString.Lazy (toStrict) -data BuiltinValue = BuiltinValue-    { builtinInp :: !String-    , builtinFrom :: !String-    , builtinTo :: !(Maybe String)-    }+data Summary = Summary+  { sBuiltinRules :: ![BuiltinHint]+  , sLhsRhsRules :: ![HintRule]+  } deriving (Show, Generic)+  deriving (ToJSON) via CustomJSON '[FieldLabelModifier (StripPrefix "s", CamelToSnake)] Summary +data BuiltinHint = BuiltinHint+  { hName :: !String+  , hSeverity :: !Severity+  , hRefactoring :: !Bool+  , hCategory :: !String+  , hExamples :: ![BuiltinExample]+  } deriving (Show, Eq, Ord, Generic)+  deriving (ToJSON) via CustomJSON '[FieldLabelModifier (StripPrefix "h", CamelToSnake)] BuiltinHint -dedupeBuiltin :: [(BuiltinKey, BuiltinValue)] -> [(BuiltinKey, BuiltinValue)]-dedupeBuiltin = Map.toAscList . Map.fromListWith (\_ old -> old)+data BuiltinKey = BuiltinKey+  { kName :: !String+  , kSeverity :: !Severity+  , kRefactoring :: !Bool+  , kCategory :: !String+  } deriving (Show, Eq, Ord) +data BuiltinExample = BuiltinExample+    { eContext :: !String+    , eFrom :: !String+    , eTo :: !(Maybe String)+    } deriving (Show, Eq, Ord, Generic)+    deriving (ToJSON) via CustomJSON '[FieldLabelModifier (StripPrefix "e", CamelToSnake)] BuiltinExample --- | Generate a summary of hints, including built-in hints and YAML-configured hints--- from @data/hlint.yaml@.-generateSummary :: [Setting] -> IO String-generateSummary settings = do-    -- Do not insert if the key already exists in the map. This has the effect-    -- of picking the first test case of a hint as the example in the summary.-    builtinHints <- mkBuiltinSummary-    let lhsRhsHints = [hint | SettingMatchExp hint <- settings]-    pure $ genBuiltinSummaryMd builtinHints lhsRhsHints+dedupBuiltin :: [(BuiltinKey, BuiltinExample)] -> [BuiltinHint]+dedupBuiltin = fmap makeHint . Map.toAscList . Map.fromListWith (<>) . fmap exampleToList where+  exampleToList (k, e) = (k, [e])+  makeHint (BuiltinKey{..}, examples) = BuiltinHint+    kName+    kSeverity+    kRefactoring+    kCategory+    examples  -- | The summary of built-in hints is generated by running the test cases in--- @src/Hint/*.hs@. One entry per (hint name, severity, does it support refactoring).-mkBuiltinSummary :: IO [(String, [(BuiltinKey, BuiltinValue)])]-mkBuiltinSummary = forM builtinHints $ \(name, hint) -> (name,) <$> do-    let file = "src/Hint" </> name <.> "hs"+-- @src/Hint/*.hs@.+mkBuiltinSummary :: IO [BuiltinHint]+mkBuiltinSummary = concatForM builtinHints $ \(category, hint) -> do+    let file = "src/Hint" </> category <.> "hs"     b <- doesFileExist file     if not b then do         putStrLn $ "Couldn't find source hint file " ++ file ++ ", some hints will be missing"         pure []      else do         tests <- parseTestFile file-        fmap dedupeBuiltin <$> concatForM tests $ \(TestCase _ _ inp _ _) -> do+        fmap dedupBuiltin <$> concatForM tests $ \(TestCase _ _ inp _ _) -> do             m <- parseModuleEx defaultParseFlags file (Just inp)             pure $ case m of-                Right m -> map (ideaToValue inp) $ applyHints [] hint [m]+                Right m -> map (ideaToValue category inp) $ applyHints [] hint [m]                 Left _ -> []     where-        ideaToValue :: String -> Idea -> (BuiltinKey, BuiltinValue)-        ideaToValue inp Idea{..} = (k, v)+        ideaToValue :: String -> String -> Idea -> (BuiltinKey, BuiltinExample)+        ideaToValue category inp Idea{..} = (k, v)             where                 -- make sure Windows/Linux don't differ on path separators                 to = fmap (\x -> if "Combine with " `isPrefixOf` x then replace "\\" "/" x else x) ideaTo-                k = BuiltinKey ideaHint ideaSeverity (notNull ideaRefactoring)-                v = BuiltinValue inp ideaFrom to+                k = BuiltinKey ideaHint ideaSeverity (notNull ideaRefactoring) category+                v = BuiltinExample inp ideaFrom to +getSummary :: [Setting] -> IO Summary+getSummary settings = do+  builtinHints <- mkBuiltinSummary+  let lhsRhsHints = [hint | SettingMatchExp hint <- settings]+  pure $ Summary builtinHints lhsRhsHints -genBuiltinSummaryMd :: [(String, [(BuiltinKey, BuiltinValue)])] -> [HintRule] -> String-genBuiltinSummaryMd builtins lhsRhs = unlines $+jsonToString :: ToJSON a => a -> String+jsonToString = unpack . toStrict . encode++-- | Generate a summary of hints, including built-in hints and YAML-configured hints+generateMdSummary :: [Setting] -> IO String+generateMdSummary = fmap genSummaryMd . getSummary++generateJsonSummary :: [Setting] -> IO String+generateJsonSummary = fmap jsonToString . getSummary++generateExhaustiveConfig :: Severity -> [Setting] -> IO String+generateExhaustiveConfig severity = fmap (genExhaustiveConfig severity) . getSummary++genExhaustiveConfig :: Severity -> Summary -> String+genExhaustiveConfig severity Summary{..} = unlines $+  [ "# HLint configuration file"+  , "# https://github.com/ndmitchell/hlint"+  , "##########################"+  , ""+  , "# This file contains a template configuration file, which is typically"+  , "# placed as .hlint.yaml in the root of your project"+  , ""+  , "# All built-in hints"+  ]+    ++ (mkLine <$> sortDedup (hName <$> sBuiltinRules))+    ++ ["", "# All LHS/RHS hints"]+    ++ (mkLine <$> sortDedup (hintRuleName <$> sLhsRhsRules))+  where+    sortDedup = fmap head . group . sort+    mkLine name = "- " <> show severity <> ": {name: " <> jsonToString name <> "}"++genSummaryMd :: Summary -> String+genSummaryMd Summary{..} = unlines $   [ "# Summary of Hints"   , ""   , "This page is auto-generated from `hlint --generate-summary`."   ] ++-  concat ["" : ("## Builtin " ++ group ) : "" : builtinTable hints |  (group, hints) <- builtins] +++  concat ["" : ("## Builtin " ++ group ) : "" : builtinTable hints | (group, hints) <- groupHintsByCategory sBuiltinRules] ++   [ ""   , "## Configured hints"   , ""   ]-  ++ lhsRhsTable lhsRhs+  ++ lhsRhsTable sLhsRhsRules+  where+    groupHintsByCategory = Map.toAscList . Map.fromListWith (<>) . fmap keyCategory+    keyCategory hint = (hCategory hint, [hint])  row :: [String] -> [String] row xs = ["<tr>"] ++ xs ++ ["</tr>"]@@ -91,34 +148,35 @@   | '\n' `elem` s = ["<pre>", s, "</pre>"]   | otherwise = ["<code>", s, "</code>", "<br>"] -builtinTable :: [(BuiltinKey, BuiltinValue)] -> [String]+builtinTable :: [BuiltinHint] -> [String] builtinTable builtins =   ["<table>"]   ++ row ["<th>Hint Name</th>", "<th>Hint</th>", "<th>Severity</th>"]-  ++ concatMap (uncurry showBuiltin) builtins+  ++ concatMap showBuiltin builtins   ++ ["</table>"] -showBuiltin :: BuiltinKey -> BuiltinValue -> [String]-showBuiltin BuiltinKey{..} BuiltinValue{..} = row1+showBuiltin :: BuiltinHint -> [String]+showBuiltin BuiltinHint{..} = row1   where     row1 = row $-      [ "<td>" ++ builtinName ++ "</td>"-      , "<td>"-      , "Example:"-      ]-      ++ haskell builtinInp-      ++ ["Found:"]-      ++ haskell builtinFrom-      ++ ["Suggestion:"]-      ++ haskell to-      ++ ["Does not support refactoring." | not builtinRefactoring]+      [ "<td>" ++ hName ++ "</td>", "<td>"]+      ++ showExample (head hExamples)+      ++ ["Does not support refactoring." | not hRefactoring]       ++ ["</td>"] ++-      [ "<td>" ++ show builtinSeverity ++ "</td>"+      [ "<td>" ++ show hSeverity ++ "</td>"       ]-    to = case builtinTo of-      Nothing -> ""-      Just "" -> "Perhaps you should remove it."-      Just s -> s+    showExample BuiltinExample{..} =+      ["Example: "]+        ++ haskell eContext+        ++ ["Found:"]+        ++ haskell eFrom+        ++ ["Suggestion:"]+        ++ haskell eTo'+      where+      eTo' = case eTo of+        Nothing -> ""+        Just "" -> "Perhaps you should remove it."+        Just s -> s  lhsRhsTable :: [HintRule] -> [String] lhsRhsTable hints =
tests/flag-no-summary.test view
@@ -13,6 +13,6 @@ --------------------------------------------------------------------- RUN tests/flag-no-summary2.hs --no-summary FILE tests/flag-no-summary2.hs-main = return ()+main = pure () OUTPUT EXIT 0
tests/json.test view
@@ -18,10 +18,10 @@ FILE tests/json-two.hs foo = (+1) bar x = foo x-baz = getLine >>= return . map toUpper+baz = getLine >>= pure . upper OUTPUT [{"module":["Main"],"decl":["bar"],"severity":"Warning","hint":"Eta reduce","file":"tests/json-two.hs","startLine":2,"startColumn":1,"endLine":2,"endColumn":14,"from":"bar x = foo x","to":"bar = foo","note":[],"refactorings":"[Replace {rtype = Decl, pos = SrcSpan {startLine = 2, startCol = 1, endLine = 2, endCol = 14}, subts = [(\"body\",SrcSpan {startLine = 2, startCol = 9, endLine = 2, endCol = 12})], orig = \"bar = body\"}]"}-,{"module":["Main"],"decl":["baz"],"severity":"Suggestion","hint":"Use <&>","file":"tests/json-two.hs","startLine":3,"startColumn":7,"endLine":3,"endColumn":39,"from":"getLine >>= return . map toUpper","to":"getLine Data.Functor.<&> map toUpper","note":[],"refactorings":"[Replace {rtype = Expr, pos = SrcSpan {startLine = 3, startCol = 7, endLine = 3, endCol = 39}, subts = [(\"f\",SrcSpan {startLine = 3, startCol = 28, endLine = 3, endCol = 39}),(\"m\",SrcSpan {startLine = 3, startCol = 7, endLine = 3, endCol = 14})], orig = \"m Data.Functor.<&> f\"}]"}]+,{"module":["Main"],"decl":["baz"],"severity":"Suggestion","hint":"Use <&>","file":"tests/json-two.hs","startLine":3,"startColumn":7,"endLine":3,"endColumn":31,"from":"getLine >>= pure . upper","to":"getLine Data.Functor.<&> upper","note":[],"refactorings":"[Replace {rtype = Expr, pos = SrcSpan {startLine = 3, startCol = 7, endLine = 3, endCol = 31}, subts = [(\"f\",SrcSpan {startLine = 3, startCol = 26, endLine = 3, endCol = 31}),(\"m\",SrcSpan {startLine = 3, startCol = 7, endLine = 3, endCol = 14})], orig = \"m Data.Functor.<&> f\"}]"}]  --------------------------------------------------------------------- RUN tests/json-parse-error.hs --json
tests/serialise.test view
@@ -18,9 +18,9 @@ FILE tests/serialise-two.hs foo = (+1) bar x = foo x-baz = getLine >>= return . map toUpper+baz = getLine >>= pure . upper OUTPUT-[("tests/serialise-two.hs:2:1-13: Warning: Eta reduce\nFound:\n  bar x = foo x\nPerhaps:\n  bar = foo\n",[Replace {rtype = Decl, pos = SrcSpan {startLine = 2, startCol = 1, endLine = 2, endCol = 14}, subts = [("body",SrcSpan {startLine = 2, startCol = 9, endLine = 2, endCol = 12})], orig = "bar = body"}]),("tests/serialise-two.hs:3:7-38: Suggestion: Use <&>\nFound:\n  getLine >>= return . map toUpper\nPerhaps:\n  getLine Data.Functor.<&> map toUpper\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 3, startCol = 7, endLine = 3, endCol = 39}, subts = [("f",SrcSpan {startLine = 3, startCol = 28, endLine = 3, endCol = 39}),("m",SrcSpan {startLine = 3, startCol = 7, endLine = 3, endCol = 14})], orig = "m Data.Functor.<&> f"}])]+[("tests/serialise-two.hs:2:1-13: Warning: Eta reduce\nFound:\n  bar x = foo x\nPerhaps:\n  bar = foo\n",[Replace {rtype = Decl, pos = SrcSpan {startLine = 2, startCol = 1, endLine = 2, endCol = 14}, subts = [("body",SrcSpan {startLine = 2, startCol = 9, endLine = 2, endCol = 12})], orig = "bar = body"}]),("tests/serialise-two.hs:3:7-30: Suggestion: Use <&>\nFound:\n  getLine >>= pure . upper\nPerhaps:\n  getLine Data.Functor.<&> upper\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 3, startCol = 7, endLine = 3, endCol = 31}, subts = [("f",SrcSpan {startLine = 3, startCol = 26, endLine = 3, endCol = 31}),("m",SrcSpan {startLine = 3, startCol = 7, endLine = 3, endCol = 14})], orig = "m Data.Functor.<&> f"}])]   ---------------------------------------------------------------------