hlint 3.3 → 3.10
raw patch · 82 files changed
Files
- .hlint.yaml +11/−1
- CHANGES.txt +137/−0
- LICENSE +1/−1
- README.md +103/−16
- data/default.yaml +3/−0
- data/do-block.yaml +2/−0
- data/hintrule-implies-classify.yaml +2/−0
- data/hlint.yaml +514/−69
- data/import_style.yaml +8/−0
- data/test-restrict.yaml +2/−0
- data/wildcard.yaml +0/−1
- data/wildcards.yaml +31/−0
- hlint.cabal +20/−11
- src/Apply.hs +15/−23
- src/CC.hs +5/−4
- src/CmdLine.hs +69/−32
- src/Config/Compute.hs +11/−12
- src/Config/Haskell.hs +10/−7
- src/Config/Type.hs +54/−4
- src/Config/Yaml.hs +111/−33
- src/EmbedData.hs +5/−0
- src/Extension.hs +8/−2
- src/Fixity.hs +6/−6
- src/GHC/All.hs +66/−50
- src/GHC/Util.hs +1/−1
- src/GHC/Util/ApiAnnotation.hs +52/−42
- src/GHC/Util/Brackets.hs +20/−13
- src/GHC/Util/DynFlags.hs +5/−14
- src/GHC/Util/FreeVars.hs +72/−58
- src/GHC/Util/HsExpr.hs +63/−52
- src/GHC/Util/Scope.hs +61/−40
- src/GHC/Util/SrcLoc.hs +24/−4
- src/GHC/Util/Unify.hs +60/−19
- src/GHC/Util/View.hs +17/−17
- src/HLint.hs +44/−10
- src/Hint/All.hs +6/−3
- src/Hint/Bracket.hs +82/−38
- src/Hint/Comment.hs +9/−5
- src/Hint/Duplicate.hs +7/−7
- src/Hint/Export.hs +4/−5
- src/Hint/Extensions.hs +111/−59
- src/Hint/Fixities.hs +5/−6
- src/Hint/Import.hs +27/−21
- src/Hint/Lambda.hs +71/−62
- src/Hint/List.hs +72/−58
- src/Hint/ListRec.hs +23/−21
- src/Hint/Match.hs +28/−27
- src/Hint/Monad.hs +85/−45
- src/Hint/Naming.hs +21/−14
- src/Hint/Negation.hs +62/−0
- src/Hint/NewType.hs +37/−29
- src/Hint/NumLiteral.hs +119/−0
- src/Hint/Pattern.hs +45/−39
- src/Hint/Pragma.hs +39/−29
- src/Hint/Restrict.hs +142/−44
- src/Hint/Smell.hs +17/−19
- src/Hint/Unsafe.hs +15/−11
- src/Idea.hs +3/−2
- src/Language/Haskell/HLint.hs +10/−6
- src/Refact.hs +15/−4
- src/Report.hs +3/−2
- src/SARIF.hs +178/−0
- src/Summary.hs +119/−59
- src/Test/Annotations.hs +7/−3
- src/Test/InputOutput.hs +5/−1
- src/Timing.hs +2/−1
- src/Util.hs +23/−1
- tests/cpp.test +39/−3
- tests/do-block.test +17/−0
- tests/flag-ignore-suggestions.test +38/−0
- tests/flag-no-summary.test +1/−1
- tests/hint.test +78/−2
- tests/hintrule-implies-classify.test +12/−0
- tests/import_style.test +129/−0
- tests/json.test +2/−2
- tests/lhs.test +1/−1
- tests/no_explicit_cpp.test +17/−0
- tests/parse-error.test +4/−4
- tests/sarif.test +38/−0
- tests/serialise.test +3/−3
- tests/wildcard.test +0/−45
- tests/wildcards.test +816/−0
.hlint.yaml view
@@ -5,10 +5,18 @@ # 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: - default: false+ - name: [ImportQualifiedPost] - name: [DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving, NoMonomorphismRestriction, OverloadedStrings] - name: [MultiWayIf, PatternGuards, RecordWildCards, ViewPatterns, PatternSynonyms, TupleSections, LambdaCase] - name: [Rank2Types, ScopedTypeVariables]@@ -17,7 +25,9 @@ - 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+ - {name: CPP, within: CmdLine} # Don't think this one is really necessary - flags: - default: false@@ -62,7 +72,7 @@ # doesn't fit with the other statements - ignore: {name: Use let, within: [HLint, Test.All]}-# this const has meaingful argument names+# this const has meaningful argument names - ignore: {name: Use const, within: Config.Yaml} # TEMPORARY: this lint is deleted on HEAD - ignore: {name: Use String}
CHANGES.txt view
@@ -1,5 +1,139 @@ Changelog for HLint (* = breaking change) +3.10, released 2024-02-02+ #1617, hints for when x <*> y could be y, e.g. []+* #1594, upgrade to GHC 9.12+ #1568, add mapMaybe f (reverse x) ==> reverse (mapMaybe f x)+ #1569, avoid redundant Foldable.toList calls in Foldable operations+ #1571, rename a few hints to make them clearer+ #1599, add translated 0 0 hint for CodeWorld project+ #1600, add sum [x, y] ==> x + y+ #1549, downgrade a few of the error severities to warn+3.8, released 2024-01-15+ #1552, make --git and --ignore-glob work nicely together+ #1502, fix incorrect free variable calculation in some cases+ #1555, slightly more efficient concatMap usages (e.g. pull filter out)+ #1500, suggest avoiding NonEmpty.unzip (use Functor.unzip)+* #1544, upgrade to GHC 9.8+ #1540, correct Functor law hint, was missing brackets+3.6.1, released 2023-07-03+ Attempt to make a binary release+3.6, released 2023-06-26+ #1522, define __GLASGOW_HASKELL__ for cmdCpp+ #1519, don't suggest removing brackets that result in a parse error+ #1512, add hints to convert for [1..n] to replicateM n+ #1430, add ignore-suggestions flag+ #1517, support NO_COLOR+ #1505, don't suggest redundant brackets around constraints+ #1478, Fix no warn on (x.y) by treating x.y as atom+ #1481, more hints about concat/concatMap+ #1485, add more hints about using a Functor on a literal tuple+ #1479, add specialised not hints for notElem/notNull+ #1437, don't add/remove Monad constraints in replacements+ #1475, rules for (elem False) and (notElem True)+ #1476, generalise map-consuming rules from lists to Foldables/Traversables+ #1480, add hints about notElem and notNull+ #1482, support SARIF output+ #1470, drop support for GHC 9.0+* #1470, move to GHC 9.6 parser+ #1449, add some more generalize hints that suggest fmap instead of map+ Never suggest concatForM_, because it doesn't exist+ #1467, and groups for warning on partial functions+ #1465, improve the timing information with -v flag+ #1454, filter Just . map f ==> map Just . mapMaybe f+ #1452, add more evaluate rules, e.g. fromJust (Just x) ==> x+ #1488, add <$>/<&> hints for Either+ #1447, make <$> hints also work on <&> (dualized)+ #1450, suggest nub/sort ==> nubSort with the extra hints+ #1451, isJust y && (x == fromJust y) ==> Just x == y+ #578, don't suggest numeric underscores for < 5 digits+ #1428, rename "Use map" hints that introduce tuple sections+ #1424, don't suggest sortOn; suggest avoiding `reverse . sort`+3.5, released 2022-09-20+ #1421, change zip/repeat to map with tuple section+ #1418, add more QuickCheck hints+ #1420, suggest use of Data.Tuple.Extra.both in the extra hints+ #1407, fix some list-comp hints that applied too broadly+ #1407, suggest [ f x | x <- [y] ] to [f y]+ #1417, add some more isAlpha/isDigit suggestions+ #1411, add some empty list equivalent to "" hints+ #1416, add hints for (== True) and other bool/section values+ #1410, remove support for building with GHC 8.10+* #1410, always default to using ghc-parser instead of the GHC API+* #1410, upgrade to the GHC 9.4 parse tree+ #1408, evaluate calls of map with empty/singleton lists+ #1409, add notNull hints, e.g. notNull . concat ==> any notNull+ #1406, spot list comprehension that should be lefts/rights+ #1404, add more if/then/else to min or max hints+ #1403, add last . reverse ==> head+ #1397, evaluation rules for minimum/maximum on singleton lists+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+ #1367, add brackets on refactoring templates when needed+ #1348, make module restrict hints more powerful+ #1363, add more hints for <$>+ #1362, add support for language specifier GHC2021+ #1342, make module wildcards work with `within` restrictions+ #1340, include Restriction hints in splitSettings and argsSettings output+ #1330, make ignore: {} not ignore subsequent hints+ #1317, evaluating all/any/allM/anyM on simple lists+ #1303, allow more matches for modules doing `import Prelude ()`+ #1324, add createModuleExWithFixities+ #1336, warn on unused OverloadedRecordDot+ #1334, don't remove TypeApplications if there are type-level type applications+ #1332, suggest using iterate instead of scanl/foldl+ #1331, suggest using min/max instead of if+* #1247, move to GHC 9.2+3.3.6, released 2021-12-29+ #1326, produce release binaries+3.3.5, released 2021-12-12+ #1304, support aeson-2.0+ #1309, suggest `either Left f x` becomes `f =<< x`+ #1295, suggest TemplateHaskell to TemplateHaskellQuotes if it works+ #1292, don't say redundant bracket around pattern splices+ #1289, suggest expanding tuple sections in some cases+ #1289, suggest length [1..n] ==> max 0 n+ #1279, suggest using NumericUnderscores more if it is enabled+ #1290, move reverse out of filter+3.3.4, released 2021-08-30+ #1288, fix generation of Linux binaries+3.3.3, released 2021-08-29+ #1286, compatibility with extra-1.7.10+ #114, if OverloadedLists are enabled, don't suggest list literals+3.3.2, released 2021-08-28+ #1244, add `only` restriction to modules+ #1278, make --ignore-glob patterns also ignore directories+ #1268, move nub/sort/reverse over catMaybes/lefts/rights+ #1276, fix some incorrect unused LANGUAGE warnings+ #1271, suggest foldr (<>) mempty ==> fold (not mconcat)+ #1274, make the (& f) ==> f hint apply more+ #1264, suggest eta reduction under a where+ #1266, suggest () <$ x ==> void x+ #1223, add some traverse laws+ #1254, suggest null [x] ==> False+ #1253, suggest reverse . init ==> tail . reverse+ #1253, suggest null . concat ==> all null+ #1255, suggest filter instead of list comprehension in teaching+3.3.1, released 2021-04-26+ #1221, allow restrictions to use wildcards+ #1225, treat A{} as not-atomic for bracket hints+ #1233, -XHaskell98 and -XHaskell2010 now disable extensions too+ #1226, don't warn on top-level splices with brackets+ #1230, disable LexicalNegation by default+ #1219, suggest uncurry f (a, b) ==> f a b+ #1227, remove some excess brackets generated by refactoring 3.3, released 2021-03-14 #1212, don't suggest redundant brackets on $(x) #1215, suggest varE 'foo ==> [|foo|]@@ -9,6 +143,9 @@ Drop GHC 8.6 support #1206, require apply-refact 0.9.0.0 or higher #1205, generalize hints which were with '&' form+3.2.8, released 2021-12-27+ #1304, support aeson-2.0+ #1286, compatibility with extra-1.7.10 3.2.7, released 2021-01-16 #1202, add missing parentheses for Avoid Lambda #1201, allow matching through the & operator (similar to $)
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2006-2021.+Copyright Neil Mitchell 2006-2025. All rights reserved. Redistribution and use in source and binary forms, with or without
README.md view
@@ -1,4 +1,4 @@-# HLint [](https://hackage.haskell.org/package/hlint) [](https://www.stackage.org/package/hlint) [](https://github.com/ndmitchell/hlint/actions)+# HLint [](https://hackage.haskell.org/package/hlint) [](https://www.stackage.org/package/hlint) [](https://github.com/ndmitchell/hlint/actions) HLint is a tool for suggesting possible improvements to Haskell code. These suggestions include ideas such as using alternative functions, simplifying code and spotting redundancies. This document is structured as follows: @@ -13,13 +13,15 @@ * HLint operates on each module at a time in isolation, as a result HLint does not know about types or which names are in scope. This decision is deliberate, allowing HLint to parallelise and be used incrementally on code that may not type-check. If fixities are required to parse the code properly, they [can be supplied](./README.md#why-doesnt-hlint-know-the-fixity-for-my-custom--operator). * The presence of `seq` may cause some hints (i.e. eta-reduction) to change the semantics of a program.-* Some transformed programs may require additional type signatures, particularly if the transformations trigger the monomorphism restriction or involve rank-2 types.+* Some transformed programs may require [additional type signatures](https://stackoverflow.com/questions/16402942/how-can-eta-reduction-of-a-well-typed-function-result-in-a-type-error/), particularly if the transformations trigger the monomorphism restriction or involve rank-2 types. In rare cases, there might be [nowhere to write](https://stackoverflow.com/questions/19758828/eta-reduce-is-not-always-held-in-haskell) the required type signature. * Sometimes HLint will change the code in a way that causes values to default to different types, which may change the behaviour. * HLint assumes duplicate identical expressions within in a single expression are used at the same type. * The `RebindableSyntax` extension can cause HLint to suggest incorrect changes. * HLint can be configured with knowledge of C Pre Processor flags, but it can only see one conditional set of code at a time. * HLint turns on many language extensions so it can parse more documents, occasionally some break otherwise legal syntax - e.g. `{-#INLINE foo#-}` doesn't work with `MagicHash`, `foo $bar` means something different with `TemplateHaskell`. These extensions can be disabled with `-XNoMagicHash` or `-XNoTemplateHaskell` etc. * HLint doesn't run any custom preprocessors, e.g. [markdown-unlit](https://hackage.haskell.org/package/markdown-unlit) or [record-dot-preprocessor](https://hackage.haskell.org/package/record-dot-preprocessor), so code making use of them will usually fail to parse.+* Some hints, like `Use const`, don't work for non-lifted (i.e. unlifted and unboxed) types.+* Some language extensions like `Strict` can cause certain hints (e.g. eta reduction) to be incorrect. ## Installing and running HLint @@ -55,7 +57,7 @@ The first hint is marked as an warning, because using `concatMap` in preference to the two separate functions is always desirable. In contrast, the removal of brackets is probably a good idea, but not always. Reasons that a hint might be a suggestion include requiring an additional import, something not everyone agrees on, and functions only available in more recent versions of the base library. -Any configuration can be done via [.hlint.yaml](./README.md#customizing-the-hints) file.+Any configuration can be done via [.hlint.yaml](./README.md#customizing-the-hints) file. Any other file name, such as `.hlint.yml`, can only be used explicitly with the `--hint=FILE` option. **Bug reports:** The suggested replacement should be equivalent - please report all incorrect suggestions not mentioned as known limitations. @@ -95,6 +97,8 @@ * [hlint-test](https://hackage.haskell.org/package/hlint-test) helps you write a small test runner with HLint. * [hint-man](https://github.com/apps/hint-man) automatically submits reviews to opened pull requests in your repositories with inline hints. * [CircleCI](https://circleci.com/orbs/registry/orb/haskell-works/hlint) has a plugin to run HLint more easily.+* [haskell/actions](https://github.com/haskell/actions) has `hlint-setup` and `hlint-run` actions for GitHub.+* [haskell-actions/hlint-scan](https://github.com/haskell-actions/hlint-scan) is a GitHub action using HLint for [code scanning](https://docs.github.com/en/code-security/code-scanning/automatically-scanning-your-code-for-vulnerabilities-and-errors/about-code-scanning). ### Automatically Applying Hints @@ -200,6 +204,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?@@ -246,15 +269,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@@ -281,11 +310,11 @@ * `{-# ANN module "HLint: ignore" #-}` or `{-# HLINT ignore #-}` or `{- HLINT ignore -}` - ignore all hints in this module (use `module` literally, not the name of the module). * `{-# ANN module "HLint: ignore Eta reduce" #-}` or `{-# HLINT ignore "Eta reduce" #-}` or `{- HLINT ignore "Eta reduce" -}` - ignore all eta reduction suggestions in this module.-* `{-# ANN myFunction "HLint: ignore" #-}` or `{-# HLINT ignore myFunction #-}` or `{- HLINT ignore myFunction -}` - don't give any hints in the function `myFunction`.-* `{-# ANN myFunction "HLint: error" #-}` or `{-# HLINT error myFunction #-}` or `{- HLINT error myFunction -}` - any hint in the function `myFunction` is an error.+* `{-# ANN myDef "HLint: ignore" #-}` or `{-# HLINT ignore myDef #-}` or `{- HLINT ignore myDef -}` - don't give any hints in the definition `myDef`. This may be combined with hint names, `{- HLINT ignore myDef "Eta reduce" -}`, to only ignore that hint in that definition.+* `{-# ANN myDef "HLint: error" #-}` or `{-# HLINT error myDef #-}` or `{- HLINT error myDef -}` - any hint in the definition `myDef` is an error. * `{-# ANN module "HLint: error Use concatMap" #-}` or `{-# HLINT error "Use concatMap" #-}` or `{- HLINT error "Use concatMap" -}` - the hint to use `concatMap` is an error (you may also use `warn` or `suggest` in place of `error` for other severity levels). -For `ANN` pragmas it is important to put them _after_ any `import` statements. If you have the `OverloadedStrings` extension enabled you will need to give an explicit type to the annotation, e.g. `{-# ANN myFunction ("HLint: ignore" :: String) #-}`. The `ANN` pragmas can also increase compile times or cause more recompilation than otherwise required, since they are evaluated by `TemplateHaskell`.+For `ANN` pragmas it is important to put them _after_ any `import` statements. If you have the `OverloadedStrings` extension enabled you will need to give an explicit type to the annotation, e.g. `{-# ANN myDef ("HLint: ignore" :: String) #-}`. The `ANN` pragmas can also increase compile times or cause more recompilation than otherwise required, since they are evaluated by `TemplateHaskell`. For `{-# HLINT #-}` pragmas GHC may give a warning about an unrecognised pragma, which can be suppressed with `-Wno-unrecognised-pragmas`. @@ -295,8 +324,8 @@ * `- ignore: {name: Eta reduce}` - suppress all eta reduction suggestions. * `- ignore: {name: Eta reduce, within: [MyModule1, MyModule2]}` - suppress eta reduction hints in the `MyModule1` and `MyModule2` modules.-* `- ignore: {within: MyModule.myFunction}` - don't give any hints in the function `MyModule.myFunction`.-* `- error: {within: MyModule.myFunction}` - any hint in the function `MyModule.myFunction` is an error.+* `- ignore: {within: MyModule.myDef}` - don't give any hints in the definition `MyModule.myDef`.+* `- error: {within: MyModule.myDef}` - any hint in the definition `MyModule.myDef` is an error. * `- error: {name: Use concatMap}` - the hint to use `concatMap` is an error (you may also use `warn` or `suggest` in place of `error` for other severity levels). These directives are applied in the order they are given, with later hints overriding earlier ones.@@ -354,19 +383,73 @@ - {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: - {name: [Data.Set, Data.HashSet], as: Set} - {name: Control.Arrow, within: []} - {name: Control.Monad.State, badidents: [modify, get, put], message: "Use Control.Monad.State.Class instead"}+ - {name: Control.Exception, only: [Exception], message: "Use UnliftIO.Exception instead"} ``` -This fragment requires that all imports of `Set` must be `qualified Data.Set as Set`, enforcing consistency. It also ensures the module `Control.Arrow` can't be used anywhere. It also prevents explicit imports of the `modify` identifier from `Control.Monad.State` (this is meant to allow you to prevent people from importing reexported identifiers).+This fragment adds the following hints:+* Requires that all imports of `Set` must be `qualified Data.Set as Set`, enforcing consistency+* Ensures the module `Control.Arrow` can't be used anywhere+* Prevents explicit imports of the given identifiers from `Control.Monad.State` (e.g. to prevent people from importing reexported identifiers).+* Prevents all imports from `Control.Exception`, except `Exception` You can customize the `Note:` for restricted modules, functions and extensions, by providing a `message` field (default: `may break the code`). +Other options are available:++- `asRequired`: boolean.++ If true, `as` alias is required. Ignored if `as` is empty.+- `importStyle`: one of `'qualified'`, `'unqualified'`, `'explicit'`,+ `'explicitOrQualified'`, `'unrestricted'`.++ The preferred import style.++ `explicitOrQualified` accepts both `import Foo (a,b,c)` and `import qualified Foo`, but not `import Foo` or `import Foo hiding (x)`.++ `explicit` is basically the same, but doesn't accept `import qualified`.++ `qualified` and `unqualified` do not care about the import list at all.+- `qualifiedStyle`: either `'pre'`, `'post'` or `'unrestricted'`; how should the module be qualified? This option also affects how suggestions are formatted.++For example:++```yaml+- modules:+ - {name: [Data.Set, Data.HashSet], as: Set, asRequired: true}+ - {name: Debug, importStyle: explicitOrQualified}+ - {name: Unsafe, importStyle: qualified, qualifiedStyle: post, as: Unsafe}+ - {name: Prelude, importStyle: unqualified}+```++This:+* Requires `Data.Set` and `Data.HashSet` to be imported with alias `Set`; if imported without alias, a warning is generated.+* Says that `Debug` must be imported either qualified with post-qualification, i.e. `import Debug qualified`, or with an explicit import list, e.g. `Debug (debugPrint)`.+* Requires that `Unsafe` must always be imported qualified, and can't be aliased.+* Forbids `import qualified Prelude` and `import Prelude qualified` (with or without explicit import list).++You can match on module names using [glob](https://en.wikipedia.org/wiki/Glob_(programming))-style wildcards. Module names are treated like file paths, except that periods in module names are like directory separators in file paths. So `**.*Spec` will match `Spec`, `PreludeSpec`, `Data.ListSpec`, and many more. But `*Spec` won't match `Data.ListSpec` because of the separator. See [the filepattern library](https://hackage.haskell.org/package/filepattern) for a more thorough description of the matching.++Restrictions are unified between wildcard and specific matches. With `asRequired`, `importStyle` and `qualifiedStyle` fields, the more specific option takes precedence. The list fields are merged. With multiple wildcard matches, the precedence between them is not guaranteed (but in practice, names are sorted in the reverse lexicograpic order, and the first one wins -- which hopefully means the more specific one more often than not)++If the same module is specified multiple times, for `asRequired`, `importStyle`+and `qualifiedStyle` fields, only the first definition will take effect.++```yaml+- modules:+ - {name: [Data.Map, Data.Map.*], as: Map}+ - {name: Test.Hspec, within: **.*Spec }+ - {name: '**', qualifiedStyle: post}+```+ ## Hacking HLint Contributions to HLint are most welcome, following [my standard contribution guidelines](https://github.com/ndmitchell/neil/blob/master/README.md#contributions).@@ -398,6 +481,10 @@ Getting started on problems in HLint often means wanting to inspect a GHC parse tree to get a sense of what it looks like (to see how to match on it for example). Given a source program `Foo.hs` (say), you can get GHC to print a textual representation of `Foo`'s AST via the `-ddump-parsed-ast` flag e.g. `ghc -fforce-recomp -ddump-parsed-ast -c Foo.hs`. When you have an [`HsSyn`](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/hs-syn-type) term in your program, it's quite common to want to print it (e.g. via `Debug.Trace.trace`). Types in `HsSyn` aren't in [`Show`](https://hoogle.haskell.org/?hoogle=Show). Not all types in `HsSyn` are [`Outputable`](https://hoogle.haskell.org/?hoogle=Outputable) but when they are you can call `ppr` to get `SDoc`s. This idiom is common enough that there exists [`unsafePrettyPrint`](https://hackage.haskell.org/package/ghc-lib-parser-ex-8.10.0.16/docs/Language-Haskell-GhclibParserEx-GHC-Utils-Outputable.html#v:unsafePrettyPrint). The function [`showAstData`](https://hoogle.haskell.org/?hoogle=showAstData) can be called on any `HsSyn` term to get output like with the `dump-parsed-ast` flag. The `showAstData` approach is preferable to `ppr` when both choices exist in that two ASTs that differ only in fixity arrangements will render differently with the former.++### Generating the hints summary++The hints summary is an auto-generated list of hlint's builtin hints. This can be generated with `hlint --generate-summary`, which will output the summary to `hints.md`. ### Acknowledgements
data/default.yaml view
@@ -51,6 +51,9 @@ # # Generalise map to fmap, ++ to <> # - group: {name: generalise, enabled: true}+#+# Warn on use of partial functions+# - group: {name: partial, enabled: true} # Ignore some builtin hints
+ data/do-block.yaml view
@@ -0,0 +1,2 @@+- ignore: { }+- warn: {lhs: "case m of Just x -> y; Nothing -> Nothing", rhs: "do x <- m; y"}
+ data/hintrule-implies-classify.yaml view
@@ -0,0 +1,2 @@+- ignore: { }+- warn: {lhs: mapM, rhs: traverse}
data/hlint.yaml view
@@ -6,30 +6,34 @@ - package: name: base modules:- - import Prelude+ - import Control.Applicative - import Control.Arrow+ - import Control.Concurrent.Chan - import Control.Exception+ - import Control.Exception.Base - import Control.Monad - import Control.Monad.Trans.State- - import qualified Data.Foldable- - import Data.Foldable(asum, sequenceA_, traverse_, for_)- - import Data.Traversable(traverse, for)- - import Control.Applicative - import Data.Bifunctor+ - import Data.Char+ - import Data.Either+ - import Data.Fixed+ - import Data.Foldable(asum, sequenceA_, traverse_, for_) - import Data.Function - import Data.Int- - import Data.Char - import Data.List as Data.List - import Data.List as X+ - import Data.List.NonEmpty - import Data.Maybe - import Data.Monoid+ - import Data.Ratio+ - import Data.Traversable(traverse, for)+ - import Numeric+ - import Prelude+ - import System.Exit - import System.IO- - import Control.Concurrent.Chan - import System.Mem.Weak- - import Control.Exception.Base- - import System.Exit- - import Data.Either- - import Numeric+ - import Text.Read+ - import qualified Data.Foldable - import IO as System.IO - import List as Data.List@@ -52,6 +56,11 @@ - import Data.Attoparsec.ByteString - package:+ name: quickcheck+ modules:+ - import Test.QuickCheck++- package: name: codeworld-api modules: - import CodeWorld@@ -66,6 +75,8 @@ # I/O - warn: {lhs: putStrLn (show x), rhs: print x}+ - warn: {lhs: putStr (x ++ "\n"), rhs: putStrLn x}+ - warn: {lhs: putStr (x ++ y ++ "\n"), rhs: putStrLn (x ++ y)} - warn: {lhs: mapM_ putChar, rhs: putStr} - warn: {lhs: hGetChar stdin, rhs: getChar} - warn: {lhs: hGetLine stdin, rhs: getLine}@@ -105,18 +116,27 @@ - warn: {lhs: head (sortBy f x), rhs: minimumBy f x, side: isCompare f} - warn: {lhs: last (sortBy f x), rhs: maximumBy f x, side: isCompare f} - warn: {lhs: reverse (sortBy f x), rhs: sortBy (flip f) x, name: Avoid reverse, side: isCompare f, note: Stabilizes sort order}- - warn: {lhs: sortBy (flip (comparing f)), rhs: sortOn (Down . f)}- - warn: {lhs: sortBy (comparing f), rhs: sortOn f, side: notEq f fst && notEq f snd}+ - warn: {lhs: sortBy (flip (comparing f)), rhs: sortBy (comparing (Data.Ord.Down . f))} - warn: {lhs: reverse (sortOn f x), rhs: sortOn (Data.Ord.Down . f) x, name: Avoid reverse, note: Stabilizes sort order}- # This suggestion likely costs performance, see https://github.com/ndmitchell/hlint/issues/669#issuecomment-607154496- # - warn: {lhs: reverse (sort x), rhs: sortOn Data.Ord.Down x, name: Avoid reverse, note: Stabilizes sort order}+ - warn: {lhs: reverse (sort x), rhs: sortBy (comparing Data.Ord.Down) x, name: Avoid reverse, note: Stabilizes sort order} - hint: {lhs: flip (g `on` h), rhs: flip g `on` h, name: Move flip}- - hint: {lhs: (f `on` g) `on` h, rhs: f `on` (g . h), name: Fuse on/on}+ - hint: {lhs: (f `on` g) `on` h, rhs: f `on` (g . h), name: Use on once}+ - warn: {lhs: if a >= b then a else b, rhs: max a b}+ - warn: {lhs: if a >= b then b else a, rhs: min a b}+ - warn: {lhs: if a > b then a else b, rhs: max a b}+ - warn: {lhs: if a > b then b else a, rhs: min a b}+ - warn: {lhs: if a <= b then a else b, rhs: min a b}+ - warn: {lhs: if a <= b then b else a, rhs: max a b}+ - warn: {lhs: if a < b then a else b, rhs: min a b}+ - warn: {lhs: if a < b then b else a, rhs: max a b}+ - warn: {lhs: "maximum [a, b]", rhs: max a b}+ - warn: {lhs: "minimum [a, b]", rhs: min a b} # READ/SHOW - warn: {lhs: showsPrec 0 x "", rhs: show x}+ - warn: {lhs: "showsPrec 0 x []", rhs: show x} - warn: {lhs: readsPrec 0, rhs: reads} - warn: {lhs: showsPrec 0, rhs: shows} - hint: {lhs: showIntAtBase 16 intToDigit, rhs: showHex}@@ -125,20 +145,27 @@ # LIST - warn: {lhs: concat (map f x), rhs: concatMap f x}+ - warn: {lhs: concat (f <$> x), rhs: concatMap f x}+ - warn: {lhs: concat (x <&> f), rhs: concatMap f x} - warn: {lhs: concat (fmap f x), rhs: concatMap f x} - hint: {lhs: "concat [a, b]", rhs: a ++ b}+ - hint: {lhs: "sum [a, b]", rhs: a + b, name: "Use + directly"} - hint: {lhs: map f (map g x), rhs: map (f . g) x, name: Use map once} - hint: {lhs: concatMap f (map g x), rhs: concatMap (f . g) x, name: Fuse concatMap/map} - hint: {lhs: x !! 0, rhs: head x} - warn: {lhs: take n (repeat x), rhs: replicate n x} - warn: {lhs: map f (replicate n x), rhs: replicate n (f x)} - warn: {lhs: map f (repeat x), rhs: repeat (f x)}+ - warn: {lhs: concatMap f (repeat x), rhs: cycle (f x)}+ - warn: {lhs: concat (repeat x), rhs: cycle x} - warn: {lhs: "cycle [x]", rhs: repeat x} - warn: {lhs: head (reverse x), rhs: last x}+ - warn: {lhs: last (reverse x), rhs: head x, note: IncreasesLaziness} - warn: {lhs: head (drop n x), rhs: x !! n, side: isNat n} - warn: {lhs: head (drop n x), rhs: x !! max 0 n, side: not (isNat n) && not (isNeg n)}+ - warn: {lhs: reverse (init x), rhs: tail (reverse x)} - warn: {lhs: reverse (tail (reverse x)), rhs: init x, note: IncreasesLaziness}- - warn: {lhs: reverse (reverse x), rhs: x, note: IncreasesLaziness, name: Avoid reverse}+ - warn: {lhs: reverse (reverse x), rhs: x, note: IncreasesLaziness, name: Redundant reverse} - warn: {lhs: isPrefixOf (reverse x) (reverse y), rhs: isSuffixOf x y} - warn: {lhs: "foldr (++) []", rhs: concat} - warn: {lhs: foldr (++) "", rhs: concat}@@ -152,6 +179,8 @@ - warn: {lhs: foldr (.) id l z, rhs: foldr ($) z l} - warn: {lhs: span (not . p), rhs: break p} - warn: {lhs: break (not . p), rhs: span p}+ - warn: {lhs: span (notElem x), rhs: break (elem x), name: Use break}+ - warn: {lhs: break (notElem x), rhs: span (elem x), name: Use span} - warn: {lhs: "(takeWhile p x, dropWhile p x)", rhs: span p x, note: DecreasesLaziness} - warn: {lhs: fst (span p x), rhs: takeWhile p x} - warn: {lhs: snd (span p x), rhs: dropWhile p x}@@ -185,12 +214,16 @@ - hint: {lhs: "\\x -> [x]", rhs: "(:[])", name: "Use :"} - hint: {lhs: map f (zip x y), rhs: zipWith (curry f) x y, side: not (isApp f)} - hint: {lhs: "map f (fromMaybe [] x)", rhs: "maybe [] (map f) x"}+ - hint: {lhs: "concatMap f (fromMaybe [] x)", rhs: "maybe [] (concatMap f) x"}+ - hint: {lhs: "concat (fromMaybe [] x)", rhs: "maybe [] concat x"} - warn: {lhs: not (elem x y), rhs: notElem x y}+ - warn: {lhs: not (notElem x y), rhs: elem x y} - hint: {lhs: foldr f z (map g x), rhs: foldr (f . g) z x, name: Fuse foldr/map} - warn: {lhs: "x ++ concatMap (' ':) y", rhs: "unwords (x:y)"} - warn: {lhs: intercalate " ", rhs: unwords} - hint: {lhs: concat (intersperse x y), rhs: intercalate x y, side: notEq x " "} - hint: {lhs: concat (intersperse " " x), rhs: unwords x}+ - warn: {lhs: null (concat x), rhs: all null x} - warn: {lhs: null (filter f x), rhs: not (any f x), name: Use any} - warn: {lhs: "filter f x == []", rhs: not (any f x), name: Use any} - warn: {lhs: "filter f x /= []", rhs: any f x}@@ -208,6 +241,10 @@ - warn: {lhs: notElem False, rhs: and} - warn: {lhs: True `elem` l, rhs: or l} - warn: {lhs: False `notElem` l, rhs: and l}+ - warn: {lhs: elem False, rhs: any not, name: Use any}+ - warn: {lhs: notElem True, rhs: all not, name: Use all}+ - warn: {lhs: False `elem` l, rhs: any not l, name: Use any}+ - warn: {lhs: True `notElem` l, rhs: all not l, name: Use all} - warn: {lhs: findIndex ((==) a), rhs: elemIndex a} - warn: {lhs: findIndex (a ==), rhs: elemIndex a} - warn: {lhs: findIndex (== a), rhs: elemIndex a}@@ -217,6 +254,7 @@ - warn: {lhs: "lookup b (zip l [0..])", rhs: elemIndex b l} - hint: {lhs: "elem x [y]", rhs: x == y, note: ValidInstance Eq a} - hint: {lhs: "notElem x [y]", rhs: x /= y, note: ValidInstance Eq a}+ - hint: {lhs: "length [1..n]", rhs: max 0 n} - hint: {lhs: length x >= 0, rhs: "True", name: Length always non-negative} - hint: {lhs: 0 <= length x, rhs: "True", name: Length always non-negative} - hint: {lhs: length x > 0, rhs: not (null x), note: IncreasesLaziness, name: Use null}@@ -227,9 +265,13 @@ - warn: {lhs: drop i x, rhs: x, side: isNegZero i, name: Drop on a non-positive} - warn: {lhs: last (scanl f z x), rhs: foldl f z x} - warn: {lhs: head (scanr f z x), rhs: foldr f z x}+ - warn: {lhs: "scanl (\\x _ -> a) b (replicate c d)", rhs: "take c (iterate (\\x -> a) b)"}+ - warn: {lhs: "foldl (\\x _ -> a) b [1..c]", rhs: "iterate (\\x -> a) b !! c"} - warn: {lhs: iterate id, rhs: repeat} - warn: {lhs: zipWith f (repeat x), rhs: map (f x)}+ - warn: {lhs: zip (repeat x), rhs: "map (_noParen_ x,)", note: RequiresExtension TupleSections, name: "Use map with tuple-section"} - warn: {lhs: zipWith f y (repeat z), rhs: map (`f` z) y}+ - warn: {lhs: zip y (repeat z), rhs: "map (,_noParen_ z) y", note: RequiresExtension TupleSections, name: "Use map with tuple-section"} - warn: {lhs: listToMaybe (filter p x), rhs: find p x} - warn: {lhs: zip (take n x) (take n y), rhs: take n (zip x y)} - warn: {lhs: zip (take n x) (take m y), rhs: take (min n m) (zip x y), side: notEq n m, note: [IncreasesLaziness, DecreasesLaziness], name: Redundant take}@@ -240,22 +282,38 @@ - warn: {lhs: mempty `mappend` x, rhs: x, name: "Monoid law, left identity"} - warn: {lhs: x <> mempty, rhs: x, name: "Monoid law, right identity"} - warn: {lhs: x `mappend` mempty, rhs: x, name: "Monoid law, right identity"}- - warn: {lhs: foldr (<>) mempty, rhs: mconcat}- - warn: {lhs: foldr mappend mempty, rhs: mconcat}+ - warn: {lhs: foldr (<>) mempty, rhs: Data.Foldable.fold}+ - warn: {lhs: foldr mappend mempty, rhs: Data.Foldable.fold} - warn: {lhs: mempty x, rhs: mempty, name: Evaluate} - warn: {lhs: x `mempty` y, rhs: mempty, name: Evaluate, note: "Make sure you didn't mean to use mappend instead of mempty"} # TRAVERSABLES + - warn: {lhs: traverse pure, rhs: pure, name: "Traversable law"}+ - warn: {lhs: traverse (pure . f) x, rhs: pure (fmap f x), name: "Traversable law"} - warn: {lhs: sequenceA (map f x), rhs: traverse f x}+ - warn: {lhs: sequenceA (f <$> x), rhs: traverse f x}+ - warn: {lhs: sequenceA (x <&> f), rhs: traverse f x} - warn: {lhs: sequenceA (fmap f x), rhs: traverse f x} - warn: {lhs: sequenceA_ (map f x), rhs: traverse_ f x}+ - warn: {lhs: sequenceA_ (f <$> x), rhs: traverse_ f x}+ - warn: {lhs: sequenceA_ (x <&> f), rhs: traverse_ f x} - warn: {lhs: sequenceA_ (fmap f x), rhs: traverse_ f x} - warn: {lhs: foldMap id, rhs: fold}+ - warn: {lhs: fold (f <$> x), rhs: foldMap f x}+ - warn: {lhs: fold (x <&> f), rhs: foldMap f x} - warn: {lhs: fold (fmap f x), rhs: foldMap f x} - warn: {lhs: fold (map f x), rhs: foldMap f x}+ - warn: {lhs: foldMap f (g <$> x), rhs: foldMap (f . g) x, name: Fuse foldMap/<$>}+ - warn: {lhs: foldMap f (x <&> g), rhs: foldMap (f . g) x, name: Fuse foldMap/<&>} - warn: {lhs: foldMap f (fmap g x), rhs: foldMap (f . g) x, name: Fuse foldMap/fmap} - warn: {lhs: foldMap f (map g x), rhs: foldMap (f . g) x, name: Fuse foldMap/map}+ - warn: {lhs: traverse f (fmap g x), rhs: traverse (f . g) x, name: Fuse traverse/fmap}+ - warn: {lhs: traverse f (g <$> x), rhs: traverse (f . g) x, name: Fuse traverse/<$>}+ - warn: {lhs: traverse f (x <&> g), rhs: traverse (f . g) x, name: Fuse traverse/<&>}+ - warn: {lhs: traverse_ f (fmap g x), rhs: traverse_ (f . g) x, name: Fuse traverse_/fmap}+ - warn: {lhs: traverse_ f (g <$> x), rhs: traverse_ (f . g) x, name: Fuse traverse_/<$>}+ - warn: {lhs: traverse_ f (x <&> g), rhs: traverse_ (f . g) x, name: Fuse traverse_/<&>} # BY @@ -271,6 +329,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}@@ -308,11 +367,12 @@ - warn: {lhs: f (fst p) (snd p), rhs: uncurry f p} - warn: {lhs: "uncurry (\\x y -> z)", rhs: "\\(x,y) -> z"} - warn: {lhs: "curry (\\(x,y) -> z)", rhs: "\\x y -> z"}- - warn: {lhs: uncurry (curry f), rhs: f}- - warn: {lhs: curry (uncurry f), rhs: f}+ - warn: {lhs: uncurry (curry f), rhs: f, name: Redundant curry/uncurry}+ - warn: {lhs: curry (uncurry f), rhs: f, name: Redundant curry/uncurry}+ - warn: {lhs: "uncurry f (a, b)", rhs: f a b} - warn: {lhs: ($) (f x), rhs: f x, name: Redundant $} - warn: {lhs: (f $), rhs: f, name: Redundant $}- - warn: {lhs: (Data.Function.& f), rhs: f, name: Redundant Data.Function.&}+ - warn: {lhs: (& f), rhs: f, name: Redundant &} - hint: {lhs: \x -> y, rhs: const y, side: isAtom y && not (isWildcard y)} # If any isWildcard recursively then x may be used but not mentioned explicitly - warn: {lhs: flip f x y, rhs: f y x, side: isApp original && isAtom y}@@ -326,13 +386,18 @@ - warn: {lhs: g <**> flip f, rhs: g >>= f, name: Redundant flip} - warn: {lhs: flip f =<< g, rhs: f <*> g, name: Redundant flip} - warn: {lhs: g >>= flip f, rhs: g Control.Applicative.<**> f, name: Redundant flip}+ - warn: {lhs: ($ x) . f, rhs: flip f x} # CHAR - - warn: {lhs: a >= 'a' && a <= 'z', rhs: isAsciiLower a}- - warn: {lhs: a >= 'A' && a <= 'Z', rhs: isAsciiUpper a}- - warn: {lhs: a >= '0' && a <= '9', rhs: isDigit a}- - warn: {lhs: a >= '0' && a <= '7', rhs: isOctDigit a}+ - warn: {lhs: "a >= 'a' && a <= 'z'", rhs: isAsciiLower a}+ - warn: {lhs: "'a' <= a && a <= 'z'", rhs: isAsciiLower a}+ - warn: {lhs: "a >= 'A' && a <= 'Z'", rhs: isAsciiUpper a}+ - warn: {lhs: "'A' <= a && a <= 'Z'", rhs: isAsciiUpper a}+ - warn: {lhs: "a >= '0' && a <= '9'", rhs: isDigit a}+ - warn: {lhs: "'0' <= a && a <= '9'", rhs: isDigit a}+ - warn: {lhs: "a >= '0' && a <= '7'", rhs: isOctDigit a}+ - warn: {lhs: "'0' <= a && a <= '7'", rhs: isOctDigit a} - warn: {lhs: isLower a || isUpper a, rhs: isAlpha a} - warn: {lhs: isUpper a || isLower a, rhs: isAlpha a} @@ -342,10 +407,18 @@ - hint: {lhs: x == False, rhs: not x, name: Redundant ==} - warn: {lhs: True == a, rhs: a, name: Redundant ==} - hint: {lhs: False == a, rhs: not a, name: Redundant ==}+ - hint: {lhs: (== True), rhs: id, name: Redundant ==}+ - hint: {lhs: (== False), rhs: not, name: Redundant ==}+ - hint: {lhs: (True ==), rhs: id, name: Redundant ==}+ - hint: {lhs: (False ==), rhs: not, name: Redundant ==} - warn: {lhs: a /= True, rhs: not a, name: Redundant /=} - hint: {lhs: a /= False, rhs: a, name: Redundant /=} - warn: {lhs: True /= a, rhs: not a, name: Redundant /=} - hint: {lhs: False /= a, rhs: a, name: Redundant /=}+ - hint: {lhs: (/= True), rhs: not, name: Redundant /=}+ - hint: {lhs: (/= False), rhs: id, name: Redundant /=}+ - hint: {lhs: (True /=), rhs: not, name: Redundant /=}+ - hint: {lhs: (False /=), rhs: id, name: Redundant /=} - warn: {lhs: if a then x else x, rhs: x, note: IncreasesLaziness, name: Redundant if} - warn: {lhs: if a then True else False, rhs: a, name: Redundant if} - warn: {lhs: if a then False else True, rhs: not a, name: Redundant if}@@ -402,11 +475,15 @@ # FUNCTOR - warn: {lhs: fmap f (fmap g x), rhs: fmap (f . g) x, name: Functor law}- - warn: {lhs: f <$> g <$> x, rhs: f . g <$> x, name: Functor law}+ - warn: {lhs: f <$> (g <$> x), rhs: f . g <$> x, name: Functor law}+ - warn: {lhs: x <&> g <&> f, rhs: x <&> f . g, name: Functor law} - warn: {lhs: fmap id, rhs: id, name: Functor law} - warn: {lhs: id <$> x, rhs: x, name: Functor law}+ - warn: {lhs: x <&> id, rhs: x, name: Functor law}+ - warn: {lhs: f <$> g <$> x, rhs: f . g <$> x} - hint: {lhs: fmap f $ x, rhs: f <$> x, side: isApp x || isAtom x} - hint: {lhs: \x -> a <$> b x, rhs: fmap a . b}+ - hint: {lhs: \x -> b x <&> a, rhs: fmap a . b} - hint: {lhs: x *> pure y, rhs: x Data.Functor.$> y} - hint: {lhs: x *> return y, rhs: x Data.Functor.$> y} - hint: {lhs: pure x <* y, rhs: x Data.Functor.<$ y}@@ -417,23 +494,43 @@ - hint: {lhs: x <&> const y, rhs: x Data.Functor.$> y} - hint: {lhs: x <&> pure y, rhs: x Data.Functor.$> y} - hint: {lhs: x <&> return y, rhs: x Data.Functor.$> y}+ - warn: {lhs: "fmap f (x,b)", rhs: "(x,f b)", name: Using fmap on tuple}+ - warn: {lhs: "f <$> (x,b)", rhs: "(x,f b)", name: Using <$> on tuple}+ - warn: {lhs: "(x,b) <&> f", rhs: "(x,f b)", name: Using <&> on tuple}+ - warn: {lhs: "fmap f (x,y,b)", rhs: "(x,y,f b)", name: Using fmap on tuple}+ - warn: {lhs: "f <$> (x,y,b)", rhs: "(x,y,f b)", name: Using <$> on tuple}+ - warn: {lhs: "(x,y,b) <&> f", rhs: "(x,y,f b)", name: Using <&> on tuple} # 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: pure x *> y, rhs: "y"}+ - warn: {lhs: x <* return y, rhs: x}+ - warn: {lhs: pure x *> y, rhs: "y", name: Redundant *>}+ - warn: {lhs: return x *> y, rhs: "y", name: Redundant *>}+ - warn: {lhs: "x <*> Nothing", rhs: "Nothing" }+ - warn: {lhs: "x <*> First Nothing", rhs: "First Nothing" }+ - warn: {lhs: "x <*> Last Nothing", rhs: "Last Nothing" }+ - warn: {lhs: "x <*> Left a", rhs: "Left a" }+ - warn: {lhs: "x <*> Ap []", rhs: "Ap []" }+ - warn: {lhs: "x <*> []", rhs: "[]" } # 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}@@ -441,29 +538,41 @@ - 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}+ - warn: {lhs: sequence (f <$> x), rhs: mapM f x}+ - warn: {lhs: sequence (x <&> f), rhs: mapM f x} - warn: {lhs: sequence (fmap f x), rhs: mapM f x}+ - warn: {lhs: sequence_ (f <$> x), rhs: mapM_ f x}+ - warn: {lhs: sequence_ (x <&> f), rhs: mapM_ f x} - warn: {lhs: sequence_ (fmap f x), rhs: mapM_ f x} - hint: {lhs: flip mapM, rhs: Control.Monad.forM} - hint: {lhs: flip mapM_, rhs: Control.Monad.forM_} - hint: {lhs: flip forM, rhs: mapM} - hint: {lhs: flip forM_, rhs: mapM_} - warn: {lhs: when (not x), rhs: unless x}+ - warn: {lhs: when (notElem x y), rhs: unless (elem x y), name: Use unless} - warn: {lhs: unless (not x), rhs: when x}+ - warn: {lhs: unless (notElem x y), rhs: when (elem x y), name: Use when} - warn: {lhs: x >>= id, rhs: Control.Monad.join x} - warn: {lhs: id =<< x, rhs: Control.Monad.join x}- - warn: {lhs: id =<< x, rhs: Control.Monad.join x}- - warn: {lhs: id =<< x, rhs: Control.Monad.join x} - hint: {lhs: join (f <$> x), rhs: f =<< x}+ - hint: {lhs: join (x <&> f), 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}+ - warn: {lhs: x <&> const (), rhs: Control.Monad.void x}+ - warn: {lhs: () <$ x, rhs: Control.Monad.void x} - warn: {lhs: flip (>=>), rhs: (<=<)} - warn: {lhs: flip (<=<), rhs: (>=>)} - warn: {lhs: flip (>>=), rhs: (=<<)}@@ -474,19 +583,30 @@ - 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: pure x <&> f, rhs: pure (f x)} - warn: {lhs: f <$> return x, rhs: return (f x)}+ - warn: {lhs: return x <&> f, 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: return x *> m, rhs: m}- - warn: {lhs: pure x >> m, rhs: m}- - warn: {lhs: return x >> m, rhs: m}+ - warn: {lhs: pure x *> m, rhs: m, name: Redundant *>}+ - warn: {lhs: return x *> m, rhs: m, name: Redundant *>}+ - warn: {lhs: pure x >> m, rhs: m, name: Redundant >>}+ - warn: {lhs: return x >> m, rhs: m, name: Redundant >>}+ - warn: {lhs: "forM [1..n] (const f)", rhs: replicateM n f}+ - warn: {lhs: "for [1..n] (const f)", rhs: replicateM n f}+ - warn: {lhs: "forM [1..n] (\\_ -> x)", rhs: replicateM n x}+ - warn: {lhs: "for [1..n] (\\_ -> x)", rhs: replicateM n x} # STATE MONAD @@ -495,6 +615,8 @@ # MONAD LIST + - warn: {lhs: unzip <$> mapM f x, rhs: Control.Monad.mapAndUnzipM f x}+ - warn: {lhs: mapM f x <&> unzip, rhs: Control.Monad.mapAndUnzipM f x} - warn: {lhs: fmap unzip (mapM f x), rhs: Control.Monad.mapAndUnzipM f x} - warn: {lhs: sequence (zipWith f x y), rhs: Control.Monad.zipWithM f x y} - warn: {lhs: sequence_ (zipWith f x y), rhs: Control.Monad.zipWithM_ f x y}@@ -520,14 +642,13 @@ - warn: {lhs: flip traverse_, rhs: for_} - warn: {lhs: flip for_, rhs: traverse_} - warn: {lhs: foldr (*>) (pure ()), rhs: sequenceA_}+ - warn: {lhs: foldr (*>) (return ()), rhs: sequence_} - 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}@@ -539,6 +660,7 @@ - hint: {lhs: "if b then [x] else []", rhs: "[x | b]", name: Use list comprehension} - hint: {lhs: "if b then [] else [x]", rhs: "[x | not b]", name: Use list comprehension} - hint: {lhs: "[x | x <- y]", rhs: "y", side: isVar x, name: Redundant list comprehension}+ - hint: {lhs: "[ f x | x <- [y] ]", rhs: "[f y]", side: isVar x, name: Redundant list comprehension} # SEQ @@ -556,6 +678,9 @@ - warn: {lhs: snd (unzip x), rhs: map snd x} - hint: {lhs: "\\x y -> (x, y)", rhs: "(,)"} - hint: {lhs: "\\x y z -> (x, y, z)", rhs: "(,,)"}+ - hint: {lhs: "(,b) a", rhs: "(a,b)", side: isAtom a, name: Evaluate}+ - hint: {lhs: "(a,) b", rhs: "(a,b)", side: isAtom b, name: Evaluate}+ - warn: {lhs: "Data.List.NonEmpty.unzip", rhs: "Data.Functor.unzip", name: "Avoid NonEmpty.unzip", note: "The function is being deprecated"} # MAYBE @@ -563,18 +688,20 @@ - warn: {lhs: maybe Nothing Just, rhs: id, name: Redundant maybe} - warn: {lhs: maybe False (const True), rhs: Data.Maybe.isJust} - warn: {lhs: maybe True (const False), rhs: Data.Maybe.isNothing}- - warn: {lhs: maybe False (x ==), rhs: (Just x ==)}- - warn: {lhs: maybe True (x /=), rhs: (Just x /=)}- - warn: {lhs: maybe False (== x), rhs: (Just x ==), note: ValidInstance Eq x}- - warn: {lhs: maybe True (/= x), rhs: (Just x /=), note: ValidInstance Eq x}+ - warn: {lhs: maybe False (x ==), rhs: (Just x ==), name: Redundant maybe}+ - warn: {lhs: maybe True (x /=), rhs: (Just x /=), name: Redundant maybe}+ - warn: {lhs: maybe False (== x), rhs: (Just x ==), note: ValidInstance Eq x, name: Redundant maybe}+ - warn: {lhs: maybe True (/= x), rhs: (Just x /=), note: ValidInstance Eq x, name: Redundant maybe} # The following two hints seem to be somewhat unwelcome, e.g. # https://github.com/ndmitchell/hlint/issues/1177- - ignore: {lhs: fromMaybe False x, rhs: Just True == x} # Eta expanded, see https://github.com/ndmitchell/hlint/issues/970#issuecomment-643645053- - ignore: {lhs: fromMaybe True x, rhs: Just False /= x}+ - ignore: {lhs: fromMaybe False x, rhs: Just True == x, name: Redundant fromMaybe} # Eta expanded, see https://github.com/ndmitchell/hlint/issues/970#issuecomment-643645053+ - ignore: {lhs: fromMaybe True x, rhs: Just False /= x, name: Redundant fromMaybe} - warn: {lhs: not (isNothing x), rhs: isJust x} - warn: {lhs: not (isJust x), rhs: isNothing x} - warn: {lhs: "maybe [] (:[])", rhs: maybeToList} - warn: {lhs: catMaybes (map f x), rhs: mapMaybe f x}+ - warn: {lhs: catMaybes (f <$> x), rhs: mapMaybe f x}+ - warn: {lhs: catMaybes (x <&> f), rhs: mapMaybe f x} - warn: {lhs: catMaybes (fmap f x), rhs: mapMaybe f x} - hint: {lhs: case x of Nothing -> y; Just a -> a , rhs: Data.Maybe.fromMaybe y x, side: isAtom y, name: Replace case with fromMaybe} - hint: {lhs: case x of Just a -> a; Nothing -> y, rhs: Data.Maybe.fromMaybe y x, side: isAtom y, name: Replace case with fromMaybe}@@ -584,6 +711,10 @@ - warn: {lhs: if isJust x then f (fromJust x) else y, rhs: maybe y f x} - warn: {lhs: maybe Nothing (Just . f), rhs: fmap f} - hint: {lhs: map fromJust (filter isJust x), rhs: Data.Maybe.catMaybes x}+ - hint: {lhs: filter isJust (map f x), rhs: map Just (mapMaybe f x), name: Use mapMaybe}+ - hint: {lhs: filter isJust (f <*> x), rhs: map Just (mapMaybe f x), name: Use mapMaybe}+ - hint: {lhs: filter isJust (x <&> f), rhs: map Just (mapMaybe f x), name: Use mapMaybe}+ - hint: {lhs: filter isJust (fmap f x), rhs: map Just (mapMaybe f x), name: Use mapMaybe} - warn: {lhs: x == Nothing , rhs: isNothing x} - warn: {lhs: Nothing == x , rhs: isNothing x} - warn: {lhs: x /= Nothing , rhs: Data.Maybe.isJust x}@@ -594,32 +725,69 @@ - warn: {lhs: if isNothing x then y else fromJust x, rhs: fromMaybe y x} - warn: {lhs: if isJust x then fromJust x else y, rhs: fromMaybe y x} - warn: {lhs: isJust x && (fromJust x == y), rhs: x == Just y}+ - warn: {lhs: isJust y && (x == fromJust y), rhs: Just x == y} - warn: {lhs: mapMaybe f (map g x), rhs: mapMaybe (f . g) x, name: Fuse mapMaybe/map} - warn: {lhs: fromMaybe a (fmap f x), rhs: maybe a f x} - warn: {lhs: fromMaybe a (f <$> x), rhs: maybe a f x}+ - warn: {lhs: fromMaybe a (x <&> f), rhs: maybe a f x} - warn: {lhs: mapMaybe id, rhs: catMaybes}- - hint: {lhs: "[x | Just x <- a]", rhs: Data.Maybe.catMaybes a}+ - hint: {lhs: "[x | Just x <- a]", rhs: Data.Maybe.catMaybes a, side: isVar x} - hint: {lhs: case m of Nothing -> Nothing; Just x -> x, rhs: Control.Monad.join m} - hint: {lhs: maybe Nothing id, rhs: join} - hint: {lhs: maybe Nothing f x, rhs: f =<< x}+ - warn: {lhs: maybe x f (g <$> y), rhs: maybe x (f . g) y, name: Redundant <$>}+ - warn: {lhs: maybe x f (y <&> g), rhs: maybe x (f . g) y, name: Redundant <&>} - warn: {lhs: maybe x f (fmap g y), rhs: maybe x (f . g) y, name: Redundant fmap}+ - warn: {lhs: isJust (f <$> x), rhs: isJust x}+ - warn: {lhs: isJust (x <&> f), rhs: isJust x} - warn: {lhs: isJust (fmap f x), rhs: isJust x}+ - warn: {lhs: isNothing (f <$> x), rhs: isNothing x}+ - warn: {lhs: isNothing (x <&> f), rhs: isNothing x} - warn: {lhs: isNothing (fmap f x), rhs: isNothing x}+ - warn: {lhs: fromJust (f <$> x), rhs: f (fromJust x), note: IncreasesLaziness}+ - warn: {lhs: fromJust (x <&> f), rhs: f (fromJust x), note: IncreasesLaziness} - warn: {lhs: fromJust (fmap f x), rhs: f (fromJust x), note: IncreasesLaziness}+ - warn: {lhs: mapMaybe f (g <$> x), rhs: mapMaybe (f . g) x, name: Redundant <$>}+ - warn: {lhs: mapMaybe f (x <&> g), rhs: mapMaybe (f . g) x, name: Redundant <&>} - warn: {lhs: mapMaybe f (fmap g x), rhs: mapMaybe (f . g) x, name: Redundant fmap}+ - warn: {lhs: catMaybes (nub x), rhs: nub (catMaybes x), name: Move nub out}+ - warn: {lhs: lefts (nub x), rhs: nub (lefts x), name: Move nub out}+ - warn: {lhs: rights (nub x), rhs: nub (rights x), name: Move nub out}+ - warn: {lhs: catMaybes (reverse x), rhs: reverse (catMaybes x), name: Move reverse out}+ - warn: {lhs: lefts (reverse x), rhs: reverse (lefts x), name: Move reverse out}+ - warn: {lhs: rights (reverse x), rhs: reverse (rights x), name: Move reverse out}+ - warn: {lhs: catMaybes (sort x), rhs: sort (catMaybes x), name: Move sort out}+ - warn: {lhs: lefts (sort x), rhs: sort (lefts x), name: Move sort out}+ - warn: {lhs: rights (sort x), rhs: sort (rights x), name: Move sort out}+ - warn: {lhs: catMaybes (nubOrd x), rhs: nubOrd (catMaybes x), name: Move nubOrd out}+ - warn: {lhs: lefts (nubOrd x), rhs: nubOrd (lefts x), name: Move nubOrd out}+ - warn: {lhs: rights (nubOrd x), rhs: nubOrd (rights x), name: Move nubOrd out}+ - warn: {lhs: filter f (reverse x), rhs: reverse (filter f x), name: Move reverse out}+ - warn: {lhs: mapMaybe f (reverse x), rhs: reverse (mapMaybe f x), name: Move reverse out} # EITHER - - warn: {lhs: "[a | Left a <- a]", rhs: lefts a}- - warn: {lhs: "[a | Right a <- a]", rhs: rights a}+ - warn: {lhs: "[a | Left a <- b]", rhs: lefts b, side: isVar a}+ - warn: {lhs: "[a | Right a <- b]", rhs: rights b, side: isVar a} - warn: {lhs: either Left (Right . f), rhs: fmap f} - warn: {lhs: either f g (fmap h x), rhs: either f (g . h) x, name: Redundant fmap}+ - warn: {lhs: either f g (h <$> x), rhs: either f (g . h) x, name: Redundant <$>}+ - warn: {lhs: either f g (x <&> h), rhs: either f (g . h) x, name: Redundant <&>} - warn: {lhs: isLeft (fmap f x), rhs: isLeft x}+ - warn: {lhs: isLeft (f <$> x), rhs: isLeft x}+ - warn: {lhs: isLeft (x <&> f), rhs: isLeft x} - warn: {lhs: isRight (fmap f x), rhs: isRight x}+ - warn: {lhs: isRight (f <$> x), rhs: isRight x}+ - warn: {lhs: isRight (x <&> f), rhs: isRight x} - warn: {lhs: fromLeft x (fmap f y), rhs: fromLeft x y}+ - warn: {lhs: fromLeft x (f <$> y), rhs: fromLeft x y}+ - warn: {lhs: fromLeft x (y <&> f), rhs: fromLeft x y} - warn: {lhs: fromRight x (fmap f y), rhs: either (const x) f y}+ - warn: {lhs: fromRight x (f <$> y), rhs: either (const x) f y}+ - warn: {lhs: fromRight x (y <&> f), rhs: either (const x) f y} - warn: {lhs: either (const x) id, rhs: fromRight x} - warn: {lhs: either id (const x), rhs: fromLeft x}+ - warn: {lhs: either Left f x, rhs: f =<< x} # INFIX @@ -657,10 +825,10 @@ # CONCURRENT - hint: {lhs: mapM_ (writeChan a), rhs: writeList2Chan a}- - error: {lhs: atomically (readTVar x), rhs: readTVarIO x}- - error: {lhs: atomically (newTVar x), rhs: newTVarIO x}- - error: {lhs: atomically (newTMVar x), rhs: newTMVarIO x}- - error: {lhs: atomically newEmptyTMVar, rhs: newEmptyTMVarIO}+ - warn: {lhs: atomically (readTVar x), rhs: readTVarIO x}+ - warn: {lhs: atomically (newTVar x), rhs: newTVarIO x}+ - warn: {lhs: atomically (newTMVar x), rhs: newTMVarIO x}+ - warn: {lhs: atomically newEmptyTMVar, rhs: newEmptyTMVarIO} # TYPEABLE @@ -701,20 +869,88 @@ # FOLDABLE + - warn: {lhs: case m of Nothing -> pure (); Just x -> f x, rhs: Data.Foldable.for_ 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.for_ 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.for_ 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}+ - warn: {lhs: when (isJust m) (f (fromJust m)), rhs: Data.Foldable.for_ m f}+ - hint: {lhs: concatMap f (fmap g x), rhs: concatMap (f . g) x, name: Fuse concatMap/fmap}+ - hint: {lhs: concatMap f (g <$> x), rhs: concatMap (f . g) x, name: Fuse concatMap/<$>}+ - hint: {lhs: concatMap f (x <&> g), rhs: concatMap (f . g) x, name: Fuse concatMap/<&>}+ - warn: {lhs: null (concatMap f x), rhs: all (null . f) x}+ - warn: {lhs: or (concat x), rhs: any or x}+ - warn: {lhs: or (concatMap f x), rhs: any (or . f) x}+ - warn: {lhs: and (concat x), rhs: all and x}+ - warn: {lhs: and (concatMap f x), rhs: all (and . f) x}+ - warn: {lhs: any f (concat x), rhs: any (any f) x, name: Use any nested}+ - warn: {lhs: any f (concatMap g x), rhs: any (any f . g) x, name: Use any nested}+ - warn: {lhs: all f (concat x), rhs: all (all f) x, name: Use all nested}+ - warn: {lhs: all f (concatMap g x), rhs: all (all f . g) x, name: Use all nested}+ - warn: {lhs: fold (concatMap f x), rhs: foldMap (fold . f) x}+ - warn: {lhs: foldMap f (concatMap g x), rhs: foldMap (foldMap f . g) x, name: Use foldMap nested}+ - warn: {lhs: catMaybes (concatMap f x), rhs: concatMap (catMaybes . f) x, name: Move catMaybes}+ - warn: {lhs: catMaybes (concat x), rhs: concatMap catMaybes x, name: Move catMaybes}+ - hint: {lhs: filter f (concatMap g x), rhs: concatMap (filter f . g) x, name: Move filter}+ - hint: {lhs: filter f (concat x), rhs: concatMap (filter f) x, name: Move filter}+ - warn: {lhs: mapMaybe f (concatMap g x), rhs: concatMap (mapMaybe f . g) x, name: Move mapMaybe}+ - warn: {lhs: mapMaybe f (concat x), rhs: concatMap (mapMaybe f) x, name: Move mapMaybe}+ - warn: {lhs: or (fmap p x), rhs: any p x}+ - warn: {lhs: or (p <$> x), rhs: any p x}+ - warn: {lhs: or (x <&> p), rhs: any p x}+ - warn: {lhs: and (fmap p x), rhs: all p x}+ - warn: {lhs: and (p <$> x), rhs: all p x}+ - warn: {lhs: and (x <&> p), rhs: all p x}+ - warn: {lhs: any f (fmap g x), rhs: any (f . g) x}+ - warn: {lhs: any f (g <$> x), rhs: any (f . g) x}+ - warn: {lhs: any f (x <&> g), rhs: any (f . g) x}+ - warn: {lhs: all f (fmap g x), rhs: all (f . g) x}+ - warn: {lhs: all f (g <$> x), rhs: all (f . g) x}+ - warn: {lhs: all f (x <&> g), rhs: all (f . g) x}+ - hint: {lhs: foldr f z (fmap g x), rhs: foldr (f . g) z x, name: Fuse foldr/fmap}+ - hint: {lhs: foldr f z (g <$> x), rhs: foldr (f . g) z x, name: Fuse foldr/<$>}+ - hint: {lhs: foldr f z (x <&> g), rhs: foldr (f . g) z x, name: Fuse foldr/<&>}+ - warn: {lhs: fold (Data.Foldable.toList x), rhs: fold x}+ - warn: {lhs: foldMap f (Data.Foldable.toList x), rhs: foldMap f x}+ - warn: {lhs: foldMap' f (Data.Foldable.toList x), rhs: foldMap' f x}+ - warn: {lhs: foldr f z (Data.Foldable.toList x), rhs: foldr f z x}+ - warn: {lhs: foldr' f z (Data.Foldable.toList x), rhs: foldr' f z x}+ - warn: {lhs: foldl f z (Data.Foldable.toList x), rhs: foldl f z x}+ - warn: {lhs: foldl' f z (Data.Foldable.toList x), rhs: foldl' f z x}+ - warn: {lhs: foldr1 f (Data.Foldable.toList x), rhs: foldr1 f x}+ - warn: {lhs: foldl1 f (Data.Foldable.toList x), rhs: foldl1 f x}+ - warn: {lhs: null (Data.Foldable.toList x), rhs: null x}+ - warn: {lhs: length (Data.Foldable.toList x), rhs: length x}+ - warn: {lhs: elem y (Data.Foldable.toList x), rhs: elem y x}+ - warn: {lhs: notElem y (Data.Foldable.toList x), rhs: notElem y x}+ - warn: {lhs: maximum (Data.Foldable.toList x), rhs: maximum x}+ - warn: {lhs: minimum (Data.Foldable.toList x), rhs: minimum x}+ - warn: {lhs: maximumBy f (Data.Foldable.toList x), rhs: maximumBy f x}+ - warn: {lhs: minimumBy f (Data.Foldable.toList x), rhs: minimumBy f x}+ - warn: {lhs: sum (Data.Foldable.toList x), rhs: sum x}+ - warn: {lhs: product (Data.Foldable.toList x), rhs: product x}+ - warn: {lhs: and (Data.Foldable.toList x), rhs: and x}+ - warn: {lhs: or (Data.Foldable.toList x), rhs: or x}+ - warn: {lhs: all f (Data.Foldable.toList x), rhs: all f x}+ - warn: {lhs: any f (Data.Foldable.toList x), rhs: any f x}+ - warn: {lhs: find f (Data.Foldable.toList x), rhs: find f x}+ - warn: {lhs: concat (Data.Foldable.toList x), rhs: concat x}+ - warn: {lhs: concatMap f (Data.Foldable.toList x), rhs: concatMap f x} # STATE MONAD - warn: {lhs: f <$> Control.Monad.State.get, rhs: gets f}+ - warn: {lhs: Control.Monad.State.get <&> f, rhs: gets f} - warn: {lhs: fmap f Control.Monad.State.get, rhs: gets f} - warn: {lhs: f <$> Control.Monad.State.gets g, rhs: gets (f . g)}+ - warn: {lhs: Control.Monad.State.gets g <&> f, rhs: gets (f . g)} - warn: {lhs: fmap f (Control.Monad.State.gets g), rhs: gets (f . g)} - warn: {lhs: f <$> Control.Monad.Reader.ask, rhs: asks f}+ - warn: {lhs: Control.Monad.Reader.ask <&> f, rhs: asks f} - warn: {lhs: fmap f Control.Monad.Reader.ask, rhs: asks f} - warn: {lhs: f <$> Control.Monad.Reader.asks g, rhs: asks (f . g)}+ - warn: {lhs: Control.Monad.Reader.asks g <&> f, rhs: asks (f . g)} - warn: {lhs: fmap f (Control.Monad.Reader.asks g), rhs: asks (f . g)} - warn: {lhs: fst (runState m s), rhs: evalState m s} - warn: {lhs: snd (runState m s), rhs: execState m s}@@ -733,9 +969,20 @@ - warn: {lhs: either f g (Right y), rhs: g y, name: Evaluate} - warn: {lhs: "fst (x,y)", rhs: x, name: Evaluate} - warn: {lhs: "snd (x,y)", rhs: "y", name: Evaluate}+ - warn: {lhs: fromJust (Just x), rhs: x, name: Evaluate}+ - warn: {lhs: fromLeft y (Left x), rhs: x, name: Evaluate}+ - warn: {lhs: fromLeft y (Right x), rhs: "y", name: Evaluate}+ - warn: {lhs: fromRight y (Right x), rhs: x, name: Evaluate}+ - warn: {lhs: fromRight y (Left x), rhs: "y", name: Evaluate}+ - warn: {lhs: "head [x]", rhs: "x", name: Evaluate}+ - warn: {lhs: "last [x]", rhs: "x", name: Evaluate}+ - warn: {lhs: "tail [x]", rhs: "[]", name: Evaluate} - warn: {lhs: "init [x]", rhs: "[]", name: Evaluate}+ - warn: {lhs: "null [x]", rhs: "False", name: Evaluate} - warn: {lhs: "null []", rhs: "True", name: Evaluate}+ - warn: {lhs: "null \"\"", rhs: "True", name: Evaluate} - warn: {lhs: "length []", rhs: "0", name: Evaluate}+ - warn: {lhs: "length \"\"", rhs: "0", name: Evaluate} - warn: {lhs: "foldl f z []", rhs: z, name: Evaluate} - warn: {lhs: "foldr f z []", rhs: z, name: Evaluate} - warn: {lhs: "foldr1 f [x]", rhs: x, name: Evaluate}@@ -743,23 +990,41 @@ - warn: {lhs: "scanr1 f []", rhs: "[]", name: Evaluate} - warn: {lhs: "scanr1 f [x]", rhs: "[x]", name: Evaluate} - warn: {lhs: "take n []", rhs: "[]", note: IncreasesLaziness, name: Evaluate}+ - warn: {lhs: "take n \"\"", rhs: "\"\"", note: IncreasesLaziness, name: Evaluate} - warn: {lhs: "drop n []", rhs: "[]", note: IncreasesLaziness, name: Evaluate}+ - warn: {lhs: "drop n \"\"", rhs: "\"\"", note: IncreasesLaziness, name: Evaluate} - warn: {lhs: "takeWhile p []", rhs: "[]", name: Evaluate}+ - warn: {lhs: "takeWhile p \"\"", rhs: "\"\"", name: Evaluate} - warn: {lhs: "dropWhile p []", rhs: "[]", name: Evaluate}+ - warn: {lhs: "dropWhile p \"\"", rhs: "\"\"", name: Evaluate} - warn: {lhs: "span p []", rhs: "([],[])", name: Evaluate}- - warn: {lhs: lines "", rhs: "[]", name: Evaluate}+ - warn: {lhs: "span p \"\"", rhs: "(\"\",\"\")", name: Evaluate}+ - warn: {lhs: "lines \"\"", rhs: "[]", name: Evaluate}+ - warn: {lhs: "lines []", rhs: "[]", name: Evaluate} - warn: {lhs: "unwords []", rhs: "\"\"", name: Evaluate} - warn: {lhs: x - 0, rhs: x, name: Evaluate} - warn: {lhs: x * 1, rhs: x, name: Evaluate} - warn: {lhs: x / 1, rhs: x, name: Evaluate} - warn: {lhs: "concat [a]", rhs: a, name: Evaluate} - warn: {lhs: "concat []", rhs: "[]", name: Evaluate}+ - warn: {lhs: "concatMap f [a]", rhs: f a, name: Evaluate}+ - warn: {lhs: "concatMap f []", rhs: "[]", name: Evaluate} - warn: {lhs: "zip [] []", rhs: "[]", name: Evaluate} - warn: {lhs: const x y, rhs: x, name: Evaluate} - warn: {lhs: any (const False), rhs: const False, note: IncreasesLaziness, name: Evaluate} - warn: {lhs: all (const True), rhs: const True, note: IncreasesLaziness, name: Evaluate} - warn: {lhs: "[] ++ x", rhs: x, name: Evaluate}+ - warn: {lhs: "\"\" ++ x", rhs: x, name: Evaluate} - warn: {lhs: "x ++ []", rhs: x, name: Evaluate}+ - warn: {lhs: "x ++ \"\"", rhs: x, name: Evaluate}+ - warn: {lhs: "all f [a]", rhs: f a, name: Evaluate}+ - warn: {lhs: "all f []", rhs: "True", name: Evaluate}+ - warn: {lhs: "any f [a]", rhs: f a, name: Evaluate}+ - warn: {lhs: "any f []", rhs: "False", name: Evaluate}+ - warn: {lhs: "maximum [a]", rhs: a, name: Evaluate}+ - warn: {lhs: "minimum [a]", rhs: a, name: Evaluate}+ - warn: {lhs: "map f []", rhs: "[]", name: Evaluate}+ - warn: {lhs: "map f [a]", rhs: "[f a]", name: Evaluate} # FOLDABLE + TUPLES @@ -775,9 +1040,11 @@ - warn: {lhs: "toList (x,b)", rhs: b, name: Using toList on tuple} - warn: {lhs: "maximum (x,b)", rhs: b, name: Using maximum on tuple} - warn: {lhs: "minimum (x,b)", rhs: b, name: Using minimum on tuple}+ - warn: {lhs: "notElem e (x,b)", rhs: e /= b, name: Using notElem on tuple} - warn: {lhs: "sum (x,b)", rhs: b, name: Using sum on tuple} - warn: {lhs: "product (x,b)", rhs: b, name: Using product on tuple} - warn: {lhs: "concat (x,b)", rhs: b, name: Using concat on tuple}+ - warn: {lhs: "concatMap f (x,b)", rhs: f b, name: Using concatMap on tuple} - warn: {lhs: "and (x,b)", rhs: b, name: Using and on tuple} - warn: {lhs: "or (x,b)", rhs: b, name: Using or on tuple} - warn: {lhs: "any f (x,b)", rhs: f b, name: Using any on tuple}@@ -795,9 +1062,11 @@ - warn: {lhs: "toList (x,y,b)", rhs: b, name: Using toList on tuple} - warn: {lhs: "maximum (x,y,b)", rhs: b, name: Using maximum on tuple} - warn: {lhs: "minimum (x,y,b)", rhs: b, name: Using minimum on tuple}+ - warn: {lhs: "notElem e (x,y,b)", rhs: e /= b, name: Using notElem on tuple} - warn: {lhs: "sum (x,y,b)", rhs: b, name: Using sum on tuple} - warn: {lhs: "product (x,y,b)", rhs: b, name: Using product on tuple} - warn: {lhs: "concat (x,y,b)", rhs: b, name: Using concat on tuple}+ - warn: {lhs: "concatMap f (x,y,b)", rhs: f b, name: Using concatMap on tuple} - warn: {lhs: "and (x,y,b)", rhs: b, name: Using and on tuple} - warn: {lhs: "or (x,y,b)", rhs: b, name: Using or on tuple} - warn: {lhs: "any f (x,y,b)", rhs: f b, name: Using any on tuple}@@ -812,10 +1081,6 @@ - warn: {lhs: "Data.Map.Lazy.fromList []", rhs: Data.Map.Lazy.empty} - warn: {lhs: "Data.Map.Strict.fromList []", rhs: Data.Map.Strict.empty} - # TEMPLATE HASKELL-- - hint: {lhs: "TH.varE 'a", rhs: "[|a|]", name: Use TH quotation brackets}- - group: name: lens enabled: true@@ -836,9 +1101,9 @@ - warn: {lhs: "Control.Lens.at a . Control.Lens._Just", rhs: "Control.Lens.ix a"} - error: {lhs: "Control.Lens.has (Control.Lens.at a)", rhs: "True"}- - error: {lhs: "Control.Lens.has (a . Control.Lens.at b)", rhs: "Control.Lens.has a"}+ - warn: {lhs: "Control.Lens.has (a . Control.Lens.at b)", rhs: "Control.Lens.has a"} - error: {lhs: "Control.Lens.nullOf (Control.Lens.at a)", rhs: "False"}- - error: {lhs: "Control.Lens.nullOf (a . Control.Lens.at b)", rhs: "Control.Lens.nullOf a"}+ - warn: {lhs: "Control.Lens.nullOf (a . Control.Lens.at b)", rhs: "Control.Lens.nullOf a"} - group: name: use-lens@@ -851,6 +1116,14 @@ - warn: {lhs: "either (const Nothing) Just", rhs: preview _Right} - group:+ name: use-th-quotes+ enabled: false+ imports:+ - package base+ rules:+ - hint: {lhs: "TH.varE 'a", rhs: "[|a|]", name: Use TH quotation brackets}++- group: name: attoparsec enabled: true imports:@@ -861,6 +1134,24 @@ - 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: "Test.QuickCheck.choose (x,x)", rhs: return x}+ - warn: {lhs: "Test.QuickCheck.chooseInt (x,x)", rhs: return x}+ - warn: {lhs: "Test.QuickCheck.chooseInteger (x,x)", rhs: return x}+ - warn: {lhs: "Test.QuickCheck.chooseBoundedIntegral (x,x)", rhs: return x}+ - warn: {lhs: "Test.QuickCheck.chooseEnum (x,x)", rhs: return x}+ - warn: {lhs: Control.Monad.join (Test.QuickCheck.elements l), rhs: Test.QuickCheck.oneof l}+ - warn: {lhs: "Test.QuickCheck.elements [x]", rhs: "return x"}+ - warn: {lhs: "Test.QuickCheck.growingElements [x]", rhs: "return x"}+ - warn: {lhs: "Test.QuickCheck.oneof [x]", rhs: "x", name: Evaluate}+ - warn: {lhs: "Test.QuickCheck.frequency [(a,x)]", rhs: "x", name: Evaluate}++- group: name: generalise enabled: false imports:@@ -870,7 +1161,9 @@ - warn: {lhs: a ++ b, rhs: a <> b} - warn: {lhs: "sequence [a]", rhs: "pure <$> a"} - warn: {lhs: "x /= []", rhs: not (null x), name: Use null}+ - warn: {lhs: "x /= \"\"", rhs: not (null x), name: Use null} - warn: {lhs: "[] /= x", rhs: not (null x), name: Use null}+ - warn: {lhs: "\"\" /= x", rhs: not (null x), name: Use null} - warn: {lhs: "maybe []", rhs: foldMap} - group:@@ -906,16 +1199,114 @@ - hint: {lhs: "\\(x, y) -> [x, y]", rhs: Data.Bifoldable.biList, note: IncreasesLaziness} - hint: {lhs: const mempty, rhs: mempty} - hint: {lhs: \x -> mempty, rhs: mempty, name: Redundant lambda}+ - warn: {lhs: map f x >>= g, rhs: x >>= g . f}+ - warn: {lhs: g =<< map f x, rhs: g . f =<< x}+ - hint: {lhs: join (map f x), rhs: f =<< x}+ - warn: {lhs: map unzip (mapM f x), rhs: Control.Monad.mapAndUnzipM f x} +# Warn on partial functions whose use can be avoided relatively easily.+# These functions are in the base package, excluding IO and GHC modules.+- group:+ name: partial+ enabled: false+ imports:+ - package base+ rules:++ # Data.Bifoldable++ - warn: {lhs: bifoldr1, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: bifoldl1, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: bimaximum, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: biminimum, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: bimaximumBy, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: biminimumBy, rhs: undefined, name: Avoid partial function}++ # Data.Bits++ - warn: {lhs: bitSize x, rhs: "case bitSizeMaybe x of Just n -> n; Nothing -> error _", name: Avoid partial function}+ - warn: {lhs: shiftL x b, rhs: shift x b, name: Avoid partial function}+ - warn: {lhs: shiftR x b, rhs: shift x (-b), name: Avoid partial function}+ - warn: {lhs: unsafeShiftL x b, rhs: shift x b, name: Avoid partial function}+ - warn: {lhs: unsafeShiftR x b, rhs: shift x (-b), name: Avoid partial function}+ - warn: {lhs: rotateL x b, rhs: rotate x b, name: Avoid partial function}+ - warn: {lhs: rotateR x b, rhs: rotate x (-b), name: Avoid partial function}++ # Data.Foldable++ - warn: {lhs: foldr1, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: foldl1, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: maximum, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: minimum, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: maximumBy, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: minimumBy, rhs: undefined, name: Avoid partial function}++ # Data.List++ - warn: {lhs: head l, rhs: "case l of x:_ -> x; [] -> error _", name: Avoid partial function}+ - warn: {lhs: last l, rhs: "case reverse l of x:_ -> x; [] -> error _", name: Avoid partial function}+ - warn: {lhs: tail l, rhs: "case l of _:xs -> xs; [] -> error _", name: Avoid partial function}+ - warn: {lhs: init l, rhs: "case reverse l of _:xs -> reverse xs; [] -> error _", name: Avoid partial function}+ - warn: {lhs: l !! n, rhs: "case drop n l of x:_ -> x; [] -> error _", name: Avoid partial function}++ # Data.List.NonEmpty++ - warn: {lhs: Data.List.NonEmpty.fromList l, rhs: "case nonEmpty l of Just xs -> xs; Nothing -> error _", name: Avoid partial function}++ # Data.Maybe++ - warn: {lhs: fromJust v, rhs: "case v of Just x -> x; Nothing -> error _", name: Avoid partial function}++# Strictly warn even on partial functions in the base package whose use+# are almost unavoidable for their functionality.+- group:+ name: partial-strict+ enabled: false+ imports:+ - package base+ rules:++ # Data.Char++ - warn: {lhs: digitToInt, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: intToDigit, rhs: undefined, name: Avoid partial function}++ # Data.Fixed++ - warn: {lhs: div', rhs: undefined, name: Avoid partial function}+ - warn: {lhs: mod', rhs: undefined, name: Avoid partial function}+ - warn: {lhs: divMod', rhs: undefined, name: Avoid partial function}++ # Data.List++ - warn: {lhs: cycle, rhs: undefined, name: Avoid partial function}++ # Data.Ratio++ - warn: {lhs: x % y, rhs: undefined, name: Avoid partial function}++ # Prelude++ - warn: {lhs: succ, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: pred, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: toEnum, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: fromEnum, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: quot, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: rem, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: div, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: mod, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: quotRem, rhs: undefined, name: Avoid partial function}+ - warn: {lhs: divMod, rhs: undefined, name: Avoid partial function}+ # hints that use the 'extra' library - group: name: extra enabled: false rules: - warn: {lhs: fmap concat (forM a b), rhs: concatForM a b}+ - warn: {lhs: map concat (forM a b), rhs: concatForM a b} - warn: {lhs: concat <$> forM a b, rhs: concatForM a b}- - warn: {lhs: fmap concat (forM_ a b), rhs: concatForM_ a b}- - warn: {lhs: concat <$> forM_ a b, rhs: concatForM_ a b}+ - warn: {lhs: forM a b <&> concat, rhs: concatForM a b} - warn: {lhs: "maybe (pure ()) b a", rhs: "whenJust a b"} - warn: {lhs: "maybe (return ()) b a", rhs: "whenJust a b"} - warn: {lhs: "maybeM (pure ()) b a", rhs: "whenJustM a b"}@@ -925,16 +1316,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: pure True, name: Evaluate}+ - warn: {lhs: "anyM f [a]", rhs: f a, 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"}@@ -952,7 +1351,11 @@ - warn: {lhs: "map toUpper", rhs: "upper"} - warn: {lhs: "mergeBy compare", rhs: "merge"} - warn: {lhs: "breakEnd (not . a)", rhs: "spanEnd a"}+ - warn: {lhs: "breakEnd notNull", rhs: "spanEnd null", name: Use spanEnd}+ - warn: {lhs: "breakEnd (notElem x)", rhs: "spanEnd (elem x)", name: Use spanEnd} - warn: {lhs: "spanEnd (not . a)", rhs: "breakEnd a"}+ - warn: {lhs: "spanEnd notNull", rhs: "breakEnd null", name: Use breakEnd}+ - warn: {lhs: "spanEnd (notElem x)", rhs: "breakEnd (elem x)", name: Use breakEnd} - warn: {lhs: "mconcat (map a b)", rhs: "mconcatMap a b"} - warn: {lhs: "fromMaybe b (stripPrefix a b)", rhs: "dropPrefix a b"} - warn: {lhs: "fromMaybe b (stripSuffix a b)", rhs: "dropSuffix a b"}@@ -961,15 +1364,35 @@ - warn: {lhs: "nubOrdBy compare", rhs: "nubOrd"} - warn: {lhs: "\\a -> (a, a)", rhs: "dupe"} - warn: {lhs: "showFFloat (Just a) b \"\"", rhs: "showDP a b"}+ - warn: {lhs: "showFFloat (Just a) b []", rhs: "showDP a b"} - warn: {lhs: "readFileEncoding utf8", rhs: "readFileUTF8"} - warn: {lhs: "withFile a ReadMode hGetContents'", rhs: "readFile' a"} - warn: {lhs: "readFileEncoding' utf8", rhs: "readFileUTF8'"} - warn: {lhs: "withBinaryFile a ReadMode hGetContents'", rhs: "readFileBinary' a"} - warn: {lhs: "writeFileEncoding utf8", rhs: "writeFileUTF8"}- - warn: {lhs: "head $ x ++ [y]", rhs: "headDef y x"}- - warn: {lhs: "last $ x : y", rhs: "lastDef x y"}+ - warn: {lhs: "head (x ++ [y])", rhs: "headDef y x"}+ - warn: {lhs: "last (x : y)", rhs: "lastDef x y"} - warn: {lhs: "drop 1", rhs: "drop1"} - warn: {lhs: "dropEnd 1", rhs: "dropEnd1"}+ - warn: {lhs: span notNull, rhs: break null, name: Use break}+ - warn: {lhs: break notNull, rhs: span null, name: Use span}+ - warn: {lhs: when (notNull x), rhs: unless (null x), name: Use unless}+ - warn: {lhs: unless (notNull x), rhs: when (null x), name: Use when}+ - warn: {lhs: not (notNull x), rhs: null x}+ - warn: {lhs: notNull (concat x), rhs: any notNull x}+ - warn: {lhs: notNull (concatMap f x), rhs: any (notNull . f) x}+ - warn: {lhs: notNull (filter f x), rhs: any f x}+ - warn: {lhs: "notNull [x]", rhs: "True", name: Evaluate}+ - warn: {lhs: "notNull []", rhs: "False", name: Evaluate}+ - warn: {lhs: "notNull \"\"", rhs: "False", name: Evaluate}+ - hint: {lhs: "\\(x,y) -> (f x, f y)", rhs: both f}+ - warn: {lhs: fromLeft' (Left x), rhs: x, name: Evaluate}+ - warn: {lhs: fromRight' (Right x), rhs: x, name: Evaluate}+ - warn: {lhs: fromEither (Left x), rhs: x, name: Evaluate}+ - warn: {lhs: fromEither (Right x), rhs: x, name: Evaluate}+ - hint: {lhs: nub (sort x), rhs: nubSort x}+ - warn: {lhs: sort (nub x), rhs: nubSort x}+ - warn: {lhs: notNull x, rhs: "True", side: isTuple x, name: Using notNull on tuple} # hints that will be enabled in future - group:@@ -1004,6 +1427,7 @@ - package base - package codeworld-api rules:+ - warn: {lhs: "pictures []", rhs: blank, name: Evaluate} - warn: {lhs: "pictures [ p ]", rhs: p, name: Evaluate} - warn: {lhs: "pictures [ p, q ]", rhs: p & q, name: Evaluate} - hint: {lhs: foldl1 (&), rhs: pictures}@@ -1018,6 +1442,8 @@ - warn: {lhs: "lighter (- a)", rhs: "darker a"} - warn: {lhs: "duller (- a)", rhs: "brighter a"} - warn: {lhs: "darker (- a)", rhs: "lighter a"}+ - warn: {lhs: translated x y (translated u v p), rhs: translated (x + u) (y + v) p, name: Use translated once}+ - warn: {lhs: translated 0 0 p, rhs: p} - group: name: teaching@@ -1029,7 +1455,8 @@ - hint: {lhs: "[] /= x", rhs: not (null x), name: Use null} - hint: {lhs: "not (x || y)", rhs: "not x && not y", name: Apply De Morgan law} - hint: {lhs: "not (x && y)", rhs: "not x || not y", name: Apply De Morgan law}- - hint: {lhs: "[ f x | x <- l ]", rhs: map f l}+ - hint: {lhs: "[ f x | x <- l ]", rhs: map f l, side: isVar x}+ - hint: {lhs: "[ x | x <- l, p x ]", rhs: filter p l, side: isVar x} - warn: {lhs: foldr f c (reverse x), rhs: foldl (flip f) c x, name: Use left fold instead of right fold} - warn: {lhs: foldr1 f (reverse x), rhs: foldl1 (flip f) x, name: Use left fold instead of right fold} - warn: {lhs: foldl f c (reverse x), rhs: foldr (flip f) c x, note: IncreasesLaziness, name: Use right fold instead of left fold}@@ -1115,6 +1542,8 @@ # yes = a & (mapped . b) %~ c -- a <&> b %~ c # test a = foo (\x -> True) -- const True # test a = foo (\_ -> True) -- const True+# {-# LANGUAGE NamedFieldPuns #-}; data Foo = Foo {foo :: Int}; issue1430_ctor x = f (\foo-> Foo{foo})+# {-# LANGUAGE NamedFieldPuns #-}; data Foo = Foo {foo :: Int}; issue1430_update x = f (\foo -> x{foo}) # test a = foo (\x -> x) -- id # h a = flip f x (y z) -- f (y z) x # h a = flip f x $ y z@@ -1134,6 +1563,8 @@ # no = x ^^ 18.5 # instance Arrow (->) where first f = f *** id # yes = fromInteger 12 -- 12+# yes = if x * y > u * v then x * y else u * v -- max (x * y) (u * v)+# yes = scanl (\x _ -> x + 1) 7 (replicate 8 3) -- take 8 (iterate (\x -> x + 1) 7) # import Prelude hiding (catch); no = catch # import Control.Exception as E; no = E.catch # main = do f; putStrLn $ show x -- print x@@ -1186,6 +1617,8 @@ # foo = last (sortBy (compare `on` fst) xs) -- maximumBy (compare `on` fst) xs # g = \ f -> parseFile f >>= (\ cu -> return (f, cu)) # foo = bar $ \(x,y) -> x x y+# f = const [] . (>>= const Nothing) . const Nothing -- (const Nothing Control.Monad.<=< const Nothing)+# f = g . either Left h x -- (h =<< x) # foo = (\x -> f x >>= g) -- f Control.Monad.>=> g # foo = (\f -> h f >>= g) -- h Control.Monad.>=> g # foo = (\f -> h f >>= f)@@ -1194,7 +1627,7 @@ # f condition tChar tBool = if condition then _monoField tChar else _monoField tBool # foo = maybe Bar{..} id -- Data.Maybe.fromMaybe Bar{..} # foo = (\a -> Foo {..}) 1-# foo = zipWith SymInfo [0 ..] (repeat ty) -- map (`SymInfo` ty) [0 ..] @NoRefactor+# foo = zipWith SymInfo [0 ..] (repeat ty) -- map (`SymInfo` ty) [0 ..] # foo = zipWith (SymInfo q) [0 ..] (repeat ty) -- map (( \ x_ -> SymInfo q x_ ty)) [0 .. ] @NoRefactor # f rec = rec # mean x = fst $ foldl (\(m, n) x' -> (m+(x'-m)/(n+1),n+1)) (0,0) x@@ -1221,9 +1654,8 @@ # issue1058 n = [] ++ issue1058 (n+1) -- issue1058 (n+1) # issue1183 = (a >= 'a') && a <= 'z' -- isAsciiLower a # issue1183 = (a >= 'a') && (a <= 'z') -- isAsciiLower a+# issue1218 = uncurry (zipWith g) $ (a, b) -- zipWith g a b -# import Language.Haskell.TH\-# yes = varE 'foo -- [|foo|] # import Prelude \ # yes = flip mapM -- Control.Monad.forM # import Control.Monad \@@ -1251,10 +1683,23 @@ # import Prelude((==)) \ # import qualified Prelude as P \ # main = P.length xs == 0 -- P.null xs+# import Prelude () \+# main = length xs == 0 -- null xs+# import Prelude () \+# import Foo \+# main = length xs == 0 -- null xs+# import Prelude () \+# import Data.Text (length) \+# main = length xs == 0+# import Prelude () \+# import qualified Data.Text (length) \+# main = length xs == 0 -- null xs # main = hello .~ Just 12 -- hello ?~ 12 # foo = liftIO $ window `on` deleteEvent $ do a; b # no = sort <$> f input `shouldBe` sort <$> x-# sortBy (comparing length) -- sortOn length+# no = sortBy (comparing Down)+# yes = sortBy (flip (comparing f)) -- sortBy (comparing (Data.Ord.Down . f))+# yes = reverse (sort x) -- sortBy (comparing Data.Ord.Down) x # myJoin = on $ child ^. ChildParentId ==. parent ^. ParentId # foo = typeOf (undefined :: Foo Int) -- typeRep (Proxy :: Proxy (Foo Int)) # foo = typeOf (undefined :: a) -- typeRep (Proxy :: Proxy a)
+ data/import_style.yaml view
@@ -0,0 +1,8 @@+- modules:+ - {name: HypotheticalModule1, as: HM1, asRequired: true}+ - {name: HypotheticalModule2, importStyle: explicitOrQualified}+ - {name: HypotheticalModule3, importStyle: qualified}+ - {name: 'HypotheticalModule3.*', importStyle: unqualified}+ - {name: 'HypotheticalModule3.OtherSubModule', importStyle: unrestricted, qualifiedStyle: post}+ - {name: HypotheticalModule4, importStyle: qualified, as: HM4, asRequired: true}+ - {name: HypotheticalModule5, importStyle: qualified, qualifiedStyle: post}
data/test-restrict.yaml view
@@ -1,6 +1,8 @@ - modules: - {name: Restricted.Module, within: []} - {name: Restricted.Module.Message, within: [], message: "Custom message"}+ - {name: Restricted.Module.BadIdents, badidents: ['bad']}+ - {name: Restricted.Module.OnlyIdents, only: ['good']} - functions: - {name: restricted, within: []}
− data/wildcard.yaml
@@ -1,1 +0,0 @@-- ignore: { name: Use const, within: '**.*Spec' }
+ data/wildcards.yaml view
@@ -0,0 +1,31 @@+- modules:+ - { name: A, as: A }+ - { name: '*B', as: B }+ - { name: '**.C', as: C }+ - { name: '**.*D', as: D }+ - { name: E, within: E }+ - { name: F, within: '*F' }+ - { name: G, within: '**.G' }+ - { name: H, within: '**.*H' }+ - { name: '**.*U', within: '**.*U' }+- ignore:+ name: Use const+ within:+ - I+ - '*J'+ - '**.K'+ - '**.*L'+- extensions:+ - name: CPP+ within:+ - M+ - '*N'+ - '**.O'+ - '**.*P'+- functions:+ - name: read+ within:+ - Q+ - '*R'+ - '**.S'+ - '**.*T'
hlint.cabal view
@@ -1,13 +1,13 @@-cabal-version: >= 1.18+cabal-version: 1.18 build-type: Simple name: hlint-version: 3.3+version: 3.10 license: BSD3 license-file: LICENSE category: Development author: Neil Mitchell <ndmitchell@gmail.com> maintainer: Neil Mitchell <ndmitchell@gmail.com>-copyright: Neil Mitchell 2006-2021+copyright: Neil Mitchell 2006-2025 synopsis: Source code suggestions description: HLint gives suggestions on how to improve your source code.@@ -29,10 +29,14 @@ data/*.hs data/*.yaml tests/*.test+ -- These are needed because of haskell/cabal#7862+ data/default.yaml+ data/hlint.yaml+ data/report_template.html extra-doc-files: README.md CHANGES.txt-tested-with: GHC==9.0, GHC==8.10, GHC==8.8+tested-with: GHC==9.12, GHC==9.10, GHC==9.8 source-repository head type: git@@ -49,7 +53,7 @@ description: Use GPL libraries, specifically hscolour flag ghc-lib- default: False+ default: True manual: True description: Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported @@ -68,24 +72,25 @@ utf8-string, data-default >= 0.3, cpphs >= 1.20.1,- cmdargs >= 0.10,+ cmdargs >= 0.10.22, uniplate >= 1.5, 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.0.0) && impl(ghc < 9.1.0)+ if !flag(ghc-lib) && impl(ghc >= 9.12.1) && impl(ghc < 9.13.0) build-depends:- ghc == 9.0.*,+ ghc == 9.12.*, ghc-boot-th, ghc-boot else build-depends:- ghc-lib-parser == 9.0.*+ ghc-lib-parser == 9.12.* build-depends:- ghc-lib-parser-ex >= 9.0.0.4 && < 9.0.1+ ghc-lib-parser-ex >= 9.12.0.0 && < 9.13.0 if flag(gpl) build-depends: hscolour >= 1.21@@ -119,6 +124,7 @@ Timing CC EmbedData+ SARIF Summary Config.Compute Config.Haskell@@ -153,6 +159,7 @@ Hint.Match Hint.Monad Hint.Naming+ Hint.Negation Hint.NewType Hint.Pattern Hint.Pragma@@ -160,10 +167,12 @@ Hint.Smell Hint.Type Hint.Unsafe+ Hint.NumLiteral Test.All Test.Annotations Test.InputOutput Test.Util+ ghc-options: -Wunused-binds -Wunused-imports -Worphans -Wprepositive-qualified-module executable hlint
src/Apply.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} module Apply(applyHints, applyHintFile, applyHintFiles) where @@ -16,11 +17,12 @@ import Config.Type import Config.Haskell import GHC.Types.SrcLoc-import GHC.Hs+import GHC.Hs hiding (comments) import Language.Haskell.GhclibParserEx.GHC.Hs-import qualified Data.HashSet as Set+import Data.HashSet qualified as Set import Prelude-import System.FilePattern (FilePattern, (?==))+import Util+import Timing -- | Apply hints to a single file, you may have the contents of the file.@@ -29,14 +31,14 @@ res <- parseModuleApply flags s file src pure $ case res of Left err -> [err]- Right m -> executeHints s [m]+ Right m -> timed "Execute hints" file (forceList $ executeHints s [m]) -- | Apply hints to multiple files, allowing cross-file hints to fire. applyHintFiles :: ParseFlags -> [Setting] -> [FilePath] -> IO [Idea] applyHintFiles flags s files = do (err, ms) <- partitionEithers <$> mapM (\file -> parseModuleApply flags s file Nothing) files- pure $ err ++ executeHints s ms+ pure $ err ++ timed "Execute hints" "all modules" (forceList $ executeHints s ms) -- | Given a way of classifying results, and a 'Hint', apply to a set of modules generating a list of 'Idea's.@@ -72,7 +74,7 @@ removeRequiresExtensionNotes :: ModuleEx -> Idea -> Idea removeRequiresExtensionNotes m = \x -> x{ideaNote = filter keep $ ideaNote x} where- exts = Set.fromList $ concatMap snd $ languagePragmas $ pragmas $ ghcAnnotations m+ exts = Set.fromList $ concatMap snd $ languagePragmas $ pragmas (comments (hsmodAnn (hsmodExt . unLoc . ghcModule $ m))) keep (RequiresExtension x) = not $ x `Set.member` exts keep _ = True @@ -90,10 +92,16 @@ Left (ParseError sl msg ctxt) -> pure $ Left $ classify [x | SettingClassify x <- s] $ rawIdeaN Error (adjustMessage msg) sl ctxt Nothing [] where+ -- important the message has "Parse error:" as the prefix so "--ignore=Parse error" works -- try and tidy up things like "parse error (mismatched brackets)" to not look silly adjustMessage :: String -> String- adjustMessage x = "Parse error: " ++ dropBrackets (dropPrefix "parse error " x)+ adjustMessage x = "Parse error: " ++ dropBrackets (+ case stripInfix "parse error " x of+ Nothing -> x+ Just (prefix, _) ->+ dropPrefix (prefix ++ "parse error ") x+ ) dropBrackets ('(':xs) | Just (xs,')') <- unsnoc xs = xs dropBrackets xs = xs@@ -116,19 +124,3 @@ | otherwise = r x ~= y = x == "" || any (wildcardMatch x) y x ~~= y = x == "" || x == y || ((x ++ ":") `isPrefixOf` y)---- | Returns true if the pattern matches the string. For example:------ >>> let isSpec = wildcardMatch "**.*Spec"--- >>> isSpec "Example"--- False--- >>> isSpec "ExampleSpec"--- True--- >>> isSpec "Namespaced.ExampleSpec"--- True--- >>> isSpec "Deeply.Nested.ExampleSpec"--- True------ See this issue for details: <https://github.com/ndmitchell/hlint/issues/402>.-wildcardMatch :: FilePattern -> String -> Bool-wildcardMatch p m = let f = replace "." "/" in f p ?== f m
src/CC.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- |@@ -14,13 +15,13 @@ import Data.Char (toUpper) import Data.Text (Text) -import qualified Data.Text as T-import qualified Data.ByteString.Lazy.Char8 as C8+import Data.Text qualified as T+import Data.ByteString.Lazy.Char8 qualified as C8 import Idea (Idea(..), Severity(..)) -import qualified GHC.Types.SrcLoc as GHC-import qualified GHC.Util as GHC+import GHC.Types.SrcLoc qualified as GHC+import GHC.Util qualified as GHC data Issue = Issue { issueType :: Text
src/CmdLine.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost, CPP #-} {-# LANGUAGE PatternGuards, DeriveDataTypeable, TupleSections #-} {-# OPTIONS_GHC -Wno-missing-fields -fno-cse -O0 #-} @@ -9,8 +10,9 @@ import Control.Monad.Extra import Control.Exception.Extra-import qualified Data.ByteString as BS+import Data.ByteString qualified as BS import Data.Char+import Data.List.NonEmpty qualified as NE import Data.List.Extra import Data.Maybe import Data.Functor@@ -20,7 +22,7 @@ import GHC.Driver.Session hiding (verbosity) import Language.Preprocessor.Cpphs-import System.Console.ANSI(hSupportsANSIWithoutEmulation)+import System.Console.ANSI(hSupportsANSI) import System.Console.CmdArgs.Explicit(helpText, HelpFormat(..)) import System.Console.CmdArgs.Implicit import System.Directory.Extra@@ -39,6 +41,7 @@ import Paths_hlint import Data.Version import Prelude+import Config.Type (Severity (Warning)) getCmd :: [String] -> IO Cmd@@ -83,7 +86,7 @@ data ColorMode = Never -- ^ Terminal output will never be coloured. | Always -- ^ Terminal output will always be coloured.- | Auto -- ^ Terminal output will be coloured if $TERM and stdout appear to support it.+ | Auto -- ^ Terminal output will be coloured if $TERM and stdout appear to support it, and NO_COLOR is not set. deriving (Show, Typeable, Data) @@ -95,13 +98,14 @@ = CmdMain {cmdFiles :: [FilePath] -- ^ which files to run it on, nothing = none given ,cmdReports :: [FilePath] -- ^ where to generate reports- ,cmdGivenHints :: [FilePath] -- ^ which settignsfiles were explicitly given+ ,cmdGivenHints :: [FilePath] -- ^ which settings files were explicitly given ,cmdWithGroups :: [String] -- ^ groups that are given on the command line ,cmdGit :: Bool -- ^ use git ls-files to find files ,cmdColor :: ColorMode -- ^ color the result- ,cmdThreads :: Int -- ^ Numbmer of threads to use, 0 = whatever GHC has+ ,cmdThreads :: Int -- ^ Number of threads to use, 0 = whatever GHC has ,cmdIgnore :: [String] -- ^ the hints to ignore ,cmdShowAll :: Bool -- ^ display all skipped items+ ,cmdIgnoreSuggestions :: Bool -- ^ ignore suggestions ,cmdExtension :: [String] -- ^ extensions ,cmdLanguage :: [String] -- ^ the extensions (may be prefixed by "No") ,cmdCross :: Bool -- ^ work between source files, applies to hints such as duplicate code between modules@@ -116,6 +120,7 @@ ,cmdCppAnsi :: Bool ,cmdJson :: Bool -- ^ display hint data as JSON ,cmdCC :: Bool -- ^ display hint data as Code Climate Issues+ ,cmdSARIF :: Bool -- ^ display hint data as SARIF ,cmdNoSummary :: Bool -- ^ do not show the summary info ,cmdOnly :: [String] -- ^ specify which hints explicitly ,cmdNoExitCode :: Bool@@ -125,7 +130,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)@@ -141,6 +148,7 @@ ,cmdThreads = 1 &= name "threads" &= name "j" &= opt (0 :: Int) &= help "Number of threads to use (-j for all)" ,cmdIgnore = nam "ignore" &= typ "HINT" &= help "Ignore a particular hint" ,cmdShowAll = nam "show" &= help "Show all ignored ideas"+ ,cmdIgnoreSuggestions = nam_ "ignore-suggestions" &= help "Ignore suggestions, only show warnings and errors" ,cmdExtension = nam "extension" &= typ "EXT" &= help "File extensions to search (default hs/lhs)" ,cmdLanguage = nam_ "language" &= name "X" &= typ "EXTENSION" &= help "Language extensions (Arrows, NoCPP)" ,cmdCross = nam_ "cross" &= help "Work between modules"@@ -155,6 +163,7 @@ ,cmdCppAnsi = nam_ "cpp-ansi" &= help "Use CPP in ANSI compatibility mode" ,cmdJson = nam_ "json" &= help "Display hint data as JSON" ,cmdCC = nam_ "cc" &= help "Display hint data as Code Climate Issues"+ ,cmdSARIF = nam_ "sarif" &= help "Display hint data as SARIF" ,cmdNoSummary = nam_ "no-summary" &= help "Do not show summary information" ,cmdOnly = nam "only" &= typ "HINT" &= help "Specify which hints explicitly" ,cmdNoExitCode = nam_ "no-exit-code" &= help "Do not give a negative exit if hints"@@ -163,8 +172,10 @@ ,cmdRefactor = nam_ "refactor" &= help "Automatically invoke `refactor` to apply hints" ,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"- ,cmdGenerateSummary = nam_ "generate-summary" &= opt "hints.md" &= help "Generate a summary of built-in hints"+ ,cmdIgnoreGlob = nam_ "ignore-glob" &= help "Ignore paths matching glob pattern (e.g. foo/bar/*.hs)"+ ,cmdGenerateMdSummary = nam_ "generate-summary" &= opt "hints.md" &= help "Generate a summary of available hints, in Markdown 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."@@ -172,9 +183,9 @@ ,"To check all Haskell files in 'src' and generate a report type:" ," hlint src --report"] ] &= program "hlint" &= verbosity- &= summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2021")+ &= summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2025") where- nam xs = nam_ xs &= name [head xs]+ nam xs = nam_ xs &= name [NE.head $ NE.fromList xs] nam_ xs = def &= explicit &= name xs -- | Where should we find the configuration files?@@ -188,7 +199,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@@ -207,24 +221,26 @@ cmdCpp :: Cmd -> CppFlags cmdCpp cmd | cmdCppSimple cmd = CppSimple- | Cpp `elem` (fst . snd) (cmdExtensions cmd) = Cpphs defaultCpphsOptions+ | otherwise = Cpphs defaultCpphsOptions {boolopts=defaultBoolOptions{hashline=False, stripC89=True, ansi=cmdCppAnsi cmd} ,includes = cmdCppInclude cmd ,preInclude = cmdCppFile cmd- ,defines = ("__HLINT__","1") : [(a,drop1 b) | x <- cmdCppDefine cmd, let (a,b) = break (== '=') x]+ ,defines = ("__HLINT__","1") : [(a,drop1 b) | x <- cmdCppDefine cmd, let (a,b) = break (== '=') x] ++ [("__GLASGOW_HASKELL__", show (__GLASGOW_HASKELL__ :: Int))] }- | otherwise = NoCpp -- | Determines whether to use colour or not. cmdUseColour :: Cmd -> IO Bool-cmdUseColour cmd = case cmdColor cmd of- Always -> pure True- Never -> pure False- Auto -> do- supportsANSI <- hSupportsANSIWithoutEmulation stdout- pure $ Just True == supportsANSI-+cmdUseColour cmd = do+ -- https://no-color.org+ -- if NO_COLOR is set, regardless of value, we do not colour output.+ noColor <- lookupEnv "NO_COLOR"+ case cmdColor cmd of+ Always -> pure True+ Never -> pure False+ Auto -> do+ supportsANSI <- hSupportsANSI stdout+ pure $ supportsANSI && isNothing noColor "." <\> x = x x <\> y = x </> y@@ -257,13 +273,14 @@ isDir <- doesDirectoryExist $ p <\> file if isDir then do let ignoredDirectories = ["dist", "dist-newstyle"]- avoidDir x = let y = takeFileName x in "_" `isPrefixOf` y || ("." `isPrefixOf` y && not (all (== '.') y)) || y `elem` ignoredDirectories+ avoidDir x = let y = takeFileName x in "_" `isPrefixOf` y || ("." `isPrefixOf` y && not (all (== '.') y)) || y `elem` ignoredDirectories || ignore x avoidFile x = let y = takeFileName x in "." `isPrefixOf` y || ignore x xs <- listFilesInside (pure . not . avoidDir) $ p <\> file pure [x | x <- xs, drop1 (takeExtension x) `elem` exts, not $ avoidFile x] else do isFil <- doesFileExist $ p <\> file- if isFil then pure [p <\> file]+ if isFil then+ pure [p <\> file | not $ ignore $ p <\> file] else do res <- getModule p exts file case res of@@ -288,23 +305,43 @@ getExtensions :: [String] -> (Maybe Language, ([Extension], [Extension]))-getExtensions args =- (lang, foldl f (if null langs then (defaultExtensions, []) else ([], [])) exts)- where- lang = if null langs then Nothing else Just $ fromJust $ lookup (last langs) ls+getExtensions args = (lang, foldl f (startExts, []) exts)+ where+ -- If a language specifier is provided e.g. Haskell98 or+ -- Haskell2010 or GHC2021, then it represents a specific set+ -- of extensions which we default enable.++ -- If no language specifier is provided we construct our own+ -- set of extensions to default enable. The set that we+ -- construct default enables more extensions than GHC would+ -- default enable were it to be invoked without an explicit+ -- language specifier given.+ startExts :: [Extension]+ startExts = case lang of+ Nothing -> defaultExtensions+ Just _ -> GHC.Driver.Session.languageExtensions lang++ -- If multiple languages are given, the last language "wins".+ lang :: Maybe Language+ lang = fromJust . flip lookup ls . snd <$> unsnoc langs++ langs, exts :: [String] (langs, exts) = partition (isJust . flip lookup ls) args- ls = [(show x, x) | x <- [Haskell98, Haskell2010]] - f (a, e) "Haskell98" = ([], [])- f (a, e) ('N':'o':x) | Just x <- GhclibParserEx.readExtension x, let xs = expandDisable x =- (deletes xs a, xs ++ deletes xs e)+ ls :: [(String, Language)]+ ls = [(show x, x) | x <- enumerate]++ f :: ([Extension], [Extension]) -> String -> ([Extension], [Extension])+ f (a, e) ('N':'o':x) | Just x <- GhclibParserEx.readExtension x, let xs = expandDisable x = (deletes xs a, xs ++ deletes xs e) f (a, e) x | Just x <- GhclibParserEx.readExtension x = (x : delete x a, delete x e) f (a, e) x = error $ "Unknown extension: '" ++ x ++ "'" + deletes :: [Extension] -> [Extension] -> [Extension] deletes [] ys = ys- deletes (x:xs) ys = deletes xs $ delete x ys+ deletes (x : xs) ys = deletes xs $ delete x ys -- if you disable a feature that implies another feature, sometimes we should disable both -- e.g. no one knows what TemplateHaskellQuotes is https://github.com/ndmitchell/hlint/issues/1038+ expandDisable :: Extension -> [Extension] expandDisable TemplateHaskell = [TemplateHaskell, TemplateHaskellQuotes] expandDisable x = [x]
src/Config/Compute.hs view
@@ -12,7 +12,6 @@ import GHC.Hs hiding (Warning) import GHC.Types.Name.Reader import GHC.Types.Name-import GHC.Data.Bag import GHC.Types.SrcLoc import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import Language.Haskell.GhclibParserEx.GHC.Hs.Expr@@ -43,40 +42,40 @@ ["- fixity: " ++ show (unsafePrettyPrint $ toFixitySig x)] renderSetting _ = [] -findSetting :: LHsDecl GhcPs -> [Setting]+findSetting :: LocatedA (HsDecl GhcPs) -> [Setting] findSetting (L _ (ValD _ x)) = findBind x findSetting (L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =- concatMap (findBind . unLoc) $ bagToList cid_binds+ concatMap (findBind . unLoc) cid_binds findSetting (L _ (SigD _ (FixSig _ x))) = map Infix $ fromFixitySig x findSetting x = [] findBind :: HsBind GhcPs -> [Setting] findBind VarBind{var_id, var_rhs} = findExp var_id [] $ unLoc var_rhs-findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noExtField fun_matches+findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noAnn LamSingle fun_matches findBind _ = [] findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]-findExp name vs (HsLam _ MG{mg_alts=L _ [L _ Match{m_pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=L _ (EmptyLocalBinds _)}}]})- = if length m_pats == length ps then findExp name (vs++ps) $ unLoc x else []- where ps = [rdrNameStr x | L _ (VarPat _ x) <- m_pats]+findExp name vs (HsLam _ LamSingle MG{mg_alts=L _ [L _ Match{m_pats=L _ pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=(EmptyLocalBinds _)}}]})+ = if length pats == length ps then findExp name (vs++ps) $ unLoc x else []+ where ps = [rdrNameStr x | L _ (VarPat _ x) <- pats] findExp name vs HsLam{} = [] findExp name vs HsVar{} = [] findExp name vs (OpApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $- HsApp noExtField x $ noLoc $ HsPar noExtField $ noLoc $ HsApp noExtField y $ noLoc $ mkVar "_hlint"+ HsApp noExtField x $ nlHsPar $ noLocA $ HsApp noExtField y $ noLocA $ mkVar "_hlint" findExp name vs bod = [SettingMatchExp $ HintRule Warning defaultHintName [] mempty (extendInstances lhs) (extendInstances $ fromParen rhs) Nothing] where- lhs = fromParen $ noLoc $ transform f bod- rhs = apps $ map noLoc $ HsVar noExtField (noLoc name) : map snd rep+ lhs = fromParen $ noLocA $ transform f bod+ rhs = apps $ map noLocA $ HsVar noExtField (noLocA name) : map snd rep rep = zip vs $ map (mkVar . pure) ['a'..] f (HsVar _ x) | Just y <- lookup (rdrNameStr x) rep = y- f (OpApp _ x dol y) | isDol dol = HsApp noExtField x $ noLoc $ HsPar noExtField y+ f (OpApp _ x dol y) | isDol dol = HsApp noExtField x $ nlHsPar y f x = x mkVar :: String -> HsExpr GhcPs-mkVar = HsVar noExtField . noLoc . Unqual . mkVarOcc+mkVar = HsVar noExtField . noLocA . Unqual . mkVarOcc
src/Config/Haskell.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE PatternGuards, ViewPatterns, TupleSections #-} module Config.Haskell( readPragma,@@ -23,6 +24,7 @@ import GHC.Data.FastString import GHC.Parser.Annotation import GHC.Utils.Outputable+import GHC.Data.Strict qualified import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader@@ -30,13 +32,14 @@ -- | Read an {-# ANN #-} pragma and determine if it is intended for HLint. -- Return Nothing if it is not an HLint pragma, otherwise what it means. readPragma :: AnnDecl GhcPs -> Maybe Classify-readPragma (HsAnnotation _ _ provenance expr) = f expr+readPragma (HsAnnotation _ provenance expr) = f expr where name = case provenance of ValueAnnProvenance (L _ x) -> occNameStr x TypeAnnProvenance (L _ x) -> occNameStr x ModuleAnnProvenance -> "" + f :: LocatedA (HsExpr GhcPs) -> Maybe Classify f (L _ (HsLit _ (HsString _ (unpackFS -> s)))) | "hlint:" `isPrefixOf` lower s = case getSeverity a of Nothing -> errorOn expr "bad classify pragma"@@ -46,8 +49,8 @@ f (L _ (ExprWithTySig _ x _)) = f x f _ = Nothing -readComment :: Located AnnotationComment -> [Classify]-readComment c@(L pos AnnBlockComment{})+readComment :: LEpaComment -> [Classify]+readComment c@(L pos (EpaComment EpaBlockComment{} _)) | (hash, x) <- maybe (False, x) (True,) $ stripPrefix "#" x , x <- trim x , (hlint, x) <- word1 x@@ -73,15 +76,15 @@ readComment _ = [] -errorOn :: Outputable a => Located a -> String -> b+errorOn :: Outputable a => LocatedA a -> String -> b errorOn (L pos val) msg = exitMessageImpure $- showSrcSpan pos +++ showSrcSpan (locA pos) ++ ": Error while reading hint file, " ++ msg ++ "\n" ++ unsafePrettyPrint val -errorOnComment :: Located AnnotationComment -> String -> b+errorOnComment :: LEpaComment -> String -> b errorOnComment c@(L s _) msg = exitMessageImpure $ let isMultiline = isCommentMultiline c in- showSrcSpan s +++ showSrcSpan (RealSrcSpan (epaLocationRealSrcSpan s) GHC.Data.Strict.Nothing) ++ ": Error while reading hint file, " ++ msg ++ "\n" ++ (if isMultiline then "{-" else "--") ++ commentText c ++ (if isMultiline then "-}" else "")
src/Config/Type.hs view
@@ -1,19 +1,31 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-} module Config.Type( Severity(..), Classify(..), HintRule(..), Note(..), Setting(..),- Restrict(..), RestrictType(..), SmellType(..),+ Restrict(..), RestrictType(..), RestrictIdents(..), SmellType(..),+ RestrictImportStyle(..), QualifiedStyle(..), defaultHintName, isUnifyVar, showNotes, getSeverity, getRestrictType, getSmellType ) where import Data.Char import Data.List.Extra+import Data.Monoid import Prelude -import qualified GHC.Hs+import GHC.Hs qualified 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@@ -42,7 +54,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@@ -104,15 +117,52 @@ } 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) +data RestrictIdents+ = NoRestrictIdents -- No restrictions on module imports+ | ForbidIdents [String] -- Forbid importing the given identifiers from this module+ | OnlyIdents [String] -- Forbid importing all identifiers from this module, except the given identifiers+ deriving Show++instance Semigroup RestrictIdents where+ NoRestrictIdents <> ri = ri+ ri <> NoRestrictIdents = ri+ ForbidIdents x1 <> ForbidIdents y1 = ForbidIdents $ x1 <> y1+ OnlyIdents x1 <> OnlyIdents x2 = OnlyIdents $ x1 <> x2+ ri1 <> ri2 = error $ "Incompatible restrictions: " ++ show (ri1, ri2)++data RestrictImportStyle+ = ImportStyleQualified+ | ImportStyleUnqualified+ | ImportStyleExplicit+ | ImportStyleExplicitOrQualified+ | ImportStyleUnrestricted+ deriving Show++data QualifiedStyle+ = QualifiedStylePre+ | QualifiedStylePost+ | QualifiedStyleUnrestricted+ deriving Show+ data Restrict = Restrict {restrictType :: RestrictType ,restrictDefault :: Bool ,restrictName :: [String] ,restrictAs :: [String] -- for RestrictModule only, what module names you can import it as+ ,restrictAsRequired :: Alt Maybe Bool -- for RestrictModule only+ ,restrictImportStyle :: Alt Maybe RestrictImportStyle -- for RestrictModule only+ ,restrictQualifiedStyle :: Alt Maybe QualifiedStyle -- for RestrictModule only ,restrictWithin :: [(String, String)]- ,restrictBadIdents :: [String]+ ,restrictIdents :: RestrictIdents -- for RestrictModule only, what identifiers can be imported from it ,restrictMessage :: Maybe String } deriving Show
src/Config/Yaml.hs view
@@ -1,29 +1,49 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings, ViewPatterns, RecordWildCards, GeneralizedNewtypeDeriving, TupleSections #-}-{-# LANGUAGE CPP #-} module Config.Yaml( ConfigYaml,+ ConfigYamlBuiltin (..),+ ConfigYamlUser (..), readFileConfigYaml,- settingsFromConfigYaml+ settingsFromConfigYaml,+ isBuiltinYaml, ) where +#if defined(MIN_VERSION_aeson)+#if MIN_VERSION_aeson(2,0,0)+#define AESON 2+#else+#define AESON 1+#endif+#else+#define AESON 2+#endif++import GHC.Driver.Ppr+import GHC.Driver.Errors.Types+import GHC.Types.Error hiding (Severity)+ import Config.Type-import Data.Either+import Data.Either.Extra import Data.Maybe+import Data.List.NonEmpty qualified as NE import Data.List.Extra import Data.Tuple.Extra import Control.Monad.Extra-import qualified Data.Text as T-import qualified Data.Vector as V-import qualified Data.ByteString.Char8 as BS-import qualified Data.HashMap.Strict as Map+import Data.Text qualified as T+import Data.Vector qualified as V+import Data.ByteString.Char8 qualified as BS+import Data.HashMap.Strict qualified as Map import Data.Generics.Uniplate.DataOnly import GHC.All import Fixity import Extension import GHC.Unit.Module import Data.Functor+import Data.Monoid import Data.Semigroup import Timing import Prelude@@ -31,7 +51,6 @@ import GHC.Data.Bag import GHC.Parser.Lexer import GHC.Utils.Error hiding (Severity)-import GHC.Utils.Outputable import GHC.Hs import GHC.Types.SrcLoc import GHC.Types.Name.Reader@@ -40,6 +59,9 @@ import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import Data.Char+#if AESON == 2+import Data.Aeson.KeyMap (toHashMapText)+#endif #ifdef HS_YAML @@ -47,7 +69,7 @@ import Data.YAML.Aeson (encode1Strict, decode1Strict) import Data.Aeson hiding (encode) import Data.Aeson.Types (Parser)-import qualified Data.ByteString as BSS+import Data.ByteString qualified as BSS decodeFileEither :: FilePath -> IO (Either (Pos, String) ConfigYaml) decodeFileEither path = decode1Strict <$> BSS.readFile path@@ -68,18 +90,30 @@ #endif +#if AESON == 1+toHashMapText :: a -> a+toHashMapText = id+#endif -- | Read a config file in YAML format. Takes a filename, and optionally the contents. -- Fails if the YAML doesn't parse or isn't valid HLint YAML readFileConfigYaml :: FilePath -> Maybe String -> IO ConfigYaml readFileConfigYaml file contents = timedIO "Config" file $ do val <- case contents of- Nothing -> decodeFileEither file- Just src -> pure $ decodeEither' $ BS.pack src+ Nothing ->+ if isBuiltinYaml file+ then mapRight getConfigYamlBuiltin <$> decodeFileEither file+ else mapRight getConfigYamlUser <$> decodeFileEither file+ Just src -> pure $+ if isBuiltinYaml file+ then mapRight getConfigYamlBuiltin $ decodeEither' $ BS.pack src+ else mapRight getConfigYamlUser $ decodeEither' $ BS.pack src case val of Left e -> fail $ "Failed to read YAML configuration file " ++ file ++ "\n " ++ displayException e Right v -> pure v +isBuiltinYaml :: FilePath -> Bool+isBuiltinYaml = (== "data/hlint.yaml") --------------------------------------------------------------------- -- YAML DATA TYPE@@ -130,7 +164,7 @@ -- aim to show a smallish but relevant context dotDot (fromMaybe (encode focus) $ listToMaybe $ dropWhile (\x -> BS.length x > 250) $ map encode contexts) where- (steps, contexts) = unzip $ reverse path+ (steps, contexts) = Prelude.unzip $ reverse path dotDot x = let (a,b) = BS.splitAt 250 x in BS.unpack a ++ (if BS.null b then "" else "...") parseArray :: Val -> Parser [Val]@@ -138,7 +172,7 @@ parseArray v = pure [v] parseObject :: Val -> Parser (Map.HashMap T.Text Value)-parseObject (getVal -> Object x) = pure x+parseObject (getVal -> Object x) = pure (toHashMapText x) parseObject v = parseFail v "Expected an Object" parseObject1 :: Val -> Parser (String, Val)@@ -163,6 +197,12 @@ maybeParse parseValue Nothing = pure Nothing maybeParse parseValue (Just value) = Just <$> parseValue value +maybeParseEnum :: [(T.Text, a)] -> Maybe Val -> Parser (Maybe a)+maybeParseEnum _ Nothing = pure Nothing+maybeParseEnum dict (Just val) = case getVal val of+ String str | Just x <- lookup str dict -> pure $ Just x+ _ -> parseFail val . T.unpack $ "expected '" <> T.intercalate "', '" (fst <$> dict) <> "'"+ parseBool :: Val -> Parser Bool parseBool (getVal -> Bool b) = pure b parseBool v = parseFail v "Expected a Bool"@@ -196,30 +236,39 @@ case parser defaultParseFlags{enabledExtensions=configExtensions, disabledExtensions=[]} x of POk _ x -> pure x PFailed ps ->- let (_, errs) = getMessages ps baseDynFlags- errMsg = head (bagToList errs)- msg = GHC.Utils.Outputable.showSDoc baseDynFlags $ GHC.Utils.Error.pprLocErrMsg errMsg+ let errMsg = NE.head . NE.fromList . bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages ps)+ msg = showSDoc baseDynFlags $ pprLocMsgEnvelopeDefault errMsg in parseFail v $ "Failed to parse " ++ msg ++ ", when parsing:\n " ++ x --------------------------------------------------------------------- -- YAML TO DATA TYPE -instance FromJSON ConfigYaml where+newtype ConfigYamlBuiltin = ConfigYamlBuiltin { getConfigYamlBuiltin :: ConfigYaml }+ deriving (Semigroup, Monoid)++newtype ConfigYamlUser = ConfigYamlUser { getConfigYamlUser :: ConfigYaml }+ deriving (Semigroup, Monoid)++instance FromJSON ConfigYamlBuiltin where parseJSON Null = pure mempty- parseJSON x = parseConfigYaml $ newVal x+ parseJSON x = ConfigYamlBuiltin <$> parseConfigYaml True (newVal x) -parseConfigYaml :: Val -> Parser ConfigYaml-parseConfigYaml v = do+instance FromJSON ConfigYamlUser where+ parseJSON Null = pure mempty+ parseJSON x = ConfigYamlUser <$> parseConfigYaml False (newVal x)++parseConfigYaml :: Bool -> Val -> Parser ConfigYaml+parseConfigYaml isBuiltin v = do vs <- parseArray v fmap ConfigYaml $ forM vs $ \o -> do (s, v) <- parseObject1 o case s of "package" -> ConfigPackage <$> parsePackage v- "group" -> ConfigGroup <$> parseGroup v+ "group" -> ConfigGroup <$> parseGroup isBuiltin v "arguments" -> ConfigSetting . map SettingArgument <$> parseArrayString v "fixity" -> ConfigSetting <$> parseFixity v "smell" -> ConfigSetting <$> parseSmell v- _ | isJust $ getSeverity s -> ConfigGroup . ruleToGroup <$> parseRule o+ _ | isJust $ getSeverity s -> ConfigGroup . ruleToGroup <$> parseRule isBuiltin o _ | Just r <- getRestrictType s -> ConfigSetting . map SettingRestrict <$> (parseArray v >>= mapM (parseRestrict r)) _ -> parseFail v "Expecting an object with a 'package' or 'group' key, a hint or a restriction" @@ -248,12 +297,12 @@ require _ _ (Just a) = pure a require val err Nothing = parseFail val err -parseGroup :: Val -> Parser Group-parseGroup v = do+parseGroup :: Bool -> Val -> Parser Group+parseGroup isBuiltin v = do groupName <- parseField "name" v >>= parseString groupEnabled <- parseFieldOpt "enabled" v >>= maybe (pure True) parseBool groupImports <- parseFieldOpt "imports" v >>= maybe (pure []) (parseArray >=> mapM parseImport)- groupRules <- parseFieldOpt "rules" v >>= maybe (pure []) parseArray >>= concatMapM parseRule+ groupRules <- parseFieldOpt "rules" v >>= maybe (pure []) parseArray >>= concatMapM (parseRule isBuiltin) allowFields v ["name","enabled","imports","rules"] pure Group{..} where@@ -266,8 +315,8 @@ ruleToGroup :: [Either HintRule Classify] -> Group ruleToGroup = Group "" True [] -parseRule :: Val -> Parser [Either HintRule Classify]-parseRule v = do+parseRule :: Bool -> Val -> Parser [Either HintRule Classify]+parseRule isBuiltin v = do (severity, v) <- parseSeverityKey v isRule <- isJust <$> parseFieldOpt "lhs" v if isRule then do@@ -279,7 +328,9 @@ allowFields v ["lhs","rhs","note","name","side"] let hintRuleScope = mempty- pure [Left HintRule{hintRuleSeverity=severity,hintRuleLHS=extendInstances lhs,hintRuleRHS=extendInstances rhs, ..}]+ pure $+ Left HintRule {hintRuleSeverity = severity, hintRuleLHS = extendInstances lhs, hintRuleRHS = extendInstances rhs, ..}+ : [Right $ Classify severity hintRuleName "" "" | not isBuiltin] else do names <- parseFieldOpt "name" v >>= maybe (pure []) parseArrayString within <- parseFieldOpt "within" v >>= maybe (pure [("","")]) (parseArray >=> concatMapM parseWithin)@@ -292,14 +343,41 @@ Just def -> do b <- parseBool def allowFields v ["default"]- pure $ Restrict restrictType b [] [] [] [] Nothing+ pure $ Restrict restrictType b [] mempty mempty mempty mempty [] NoRestrictIdents Nothing Nothing -> do restrictName <- parseFieldOpt "name" v >>= maybe (pure []) parseArrayString restrictWithin <- parseFieldOpt "within" v >>= maybe (pure [("","")]) (parseArray >=> concatMapM parseWithin) restrictAs <- parseFieldOpt "as" v >>= maybe (pure []) parseArrayString- restrictBadIdents <- parseFieldOpt "badidents" v >>= maybe (pure []) parseArrayString+ restrictAsRequired <- parseFieldOpt "asRequired" v >>= fmap Alt . maybeParse parseBool+ restrictImportStyle <- parseFieldOpt "importStyle" v >>= fmap Alt . maybeParseEnum+ [ ("qualified" , ImportStyleQualified)+ , ("unqualified" , ImportStyleUnqualified)+ , ("explicit" , ImportStyleExplicit)+ , ("explicitOrQualified", ImportStyleExplicitOrQualified)+ , ("unrestricted" , ImportStyleUnrestricted)+ ]+ restrictQualifiedStyle <- parseFieldOpt "qualifiedStyle" v >>= fmap Alt . maybeParseEnum+ [ ("pre" , QualifiedStylePre)+ , ("post" , QualifiedStylePost)+ , ("unrestricted", QualifiedStyleUnrestricted)+ ]+++ restrictBadIdents <- parseFieldOpt "badidents" v+ restrictOnlyAllowedIdents <- parseFieldOpt "only" v+ restrictIdents <-+ case (restrictBadIdents, restrictOnlyAllowedIdents) of+ (Just badIdents, Nothing) -> ForbidIdents <$> parseArrayString badIdents+ (Nothing, Just onlyIdents) -> OnlyIdents <$> parseArrayString onlyIdents+ (Nothing, Nothing) -> pure NoRestrictIdents+ _ -> parseFail v "The following options are mutually exclusive: badidents, only"+ restrictMessage <- parseFieldOpt "message" v >>= maybeParse parseString- allowFields v $ ["as" | restrictType == RestrictModule] ++ ["badidents", "name", "within", "message"]+ allowFields v $+ ["name", "within", "message"] +++ if restrictType == RestrictModule+ then ["as", "asRequired", "importStyle", "qualifiedStyle", "badidents", "only"]+ else [] pure Restrict{restrictDefault=True,..} parseWithin :: Val -> Parser [(String, String)] -- (module, decl)@@ -363,8 +441,8 @@ where scope'= asScope' packageMap' (map (fmap unextendInstances) groupImports) -asScope' :: Map.HashMap String [LImportDecl GhcPs] -> [Either String (LImportDecl GhcPs)] -> Scope-asScope' packages xs = scopeCreate (HsModule NoLayoutInfo Nothing Nothing (concatMap f xs) [] Nothing Nothing)+asScope' :: Map.HashMap String [LocatedA (ImportDecl GhcPs)] -> [Either String (LocatedA (ImportDecl GhcPs))] -> Scope+asScope' packages xs = scopeCreate (HsModule (XModulePs noAnn EpNoLayout Nothing Nothing) Nothing Nothing (concatMap f xs) []) where f (Right x) = [x] f (Left x) | Just pkg <- Map.lookup x packages = pkg
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/Extension.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} module Extension( defaultExtensions, configExtensions,@@ -6,9 +7,9 @@ ) where import Data.List.Extra-import qualified Data.Map as Map+import Data.Map qualified as Map import GHC.LanguageExtensions.Type-import qualified Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx+import Language.Haskell.GhclibParserEx.GHC.Driver.Session qualified as GhclibParserEx badExtensions = reallyBadExtensions ++@@ -16,6 +17,10 @@ , UnboxedTuples, UnboxedSums -- breaks (#) lens operator , QuasiQuotes -- breaks [x| ...], making whitespace free list comps break , {- DoRec , -} RecursiveDo -- breaks rec+ , LexicalNegation -- changes '-', see https://github.com/ndmitchell/hlint/issues/1230+ -- These next two change syntax significantly and must be opt-in.+ , OverloadedRecordDot+ , OverloadedRecordUpdate ] reallyBadExtensions =@@ -26,6 +31,7 @@ , NegativeLiterals -- Was not enabled by HSE and enabling breaks tests. , StarIsType -- conflicts with TypeOperators. StarIsType is currently enabled by default, -- so adding it here has no effect, but it may not be the case in future GHC releases.+ , MonadComprehensions -- Discussed in https://github.com/ndmitchell/hlint/issues/1261 ] -- | Extensions we turn on by default when parsing. Aim to parse as
src/Fixity.hs view
@@ -11,8 +11,8 @@ import GHC.Hs.Extension import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader-import GHC.Types.SrcLoc-import GHC.Types.Basic+import GHC.Types.Fixity+import GHC.Parser.Annotation import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import Language.Haskell.GhclibParserEx.Fixity @@ -27,7 +27,7 @@ type FixityInfo = (String, Associativity, Int) fromFixitySig :: FixitySig GhcPs -> [FixityInfo]-fromFixitySig (FixitySig _ names (Fixity _ i dir)) =+fromFixitySig (FixitySig _ names (Fixity i dir)) = [(rdrNameStr name, f dir, i) | name <- names] where f InfixL = LeftAssociative@@ -35,14 +35,14 @@ f InfixN = NotAssociative toFixity :: FixityInfo -> (String, Fixity)-toFixity (name, dir, i) = (name, Fixity NoSourceText i $ f dir)+toFixity (name, dir, i) = (name, Fixity i $ f dir) where f LeftAssociative = InfixL f RightAssociative = InfixR f NotAssociative = InfixN fromFixity :: (String, Fixity) -> FixityInfo-fromFixity (name, Fixity _ i dir) = (name, assoc dir, i)+fromFixity (name, Fixity i dir) = (name, assoc dir, i) where assoc dir = case dir of InfixL -> LeftAssociative@@ -50,7 +50,7 @@ InfixN -> NotAssociative toFixitySig :: FixityInfo -> FixitySig GhcPs-toFixitySig (toFixity -> (name, x)) = FixitySig noExtField [noLoc $ mkRdrUnqual (mkVarOcc name)] x+toFixitySig (toFixity -> (name, x)) = FixitySig NoNamespaceSpecifier [noLocA $ mkRdrUnqual (mkVarOcc name)] x defaultFixities :: [FixityInfo] defaultFixities = map fromFixity $ customFixities ++ baseFixities ++ lensFixities ++ otherFixities
src/GHC/All.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} @@ -5,41 +6,47 @@ CppFlags(..), ParseFlags(..), defaultParseFlags, parseFlagsAddFixities, parseFlagsSetLanguage, ParseError(..), ModuleEx(..),- parseModuleEx, createModuleEx, ghcComments,+ parseModuleEx, createModuleEx, createModuleExWithFixities, ghcComments, modComments, firstDeclComments, parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode, ) where +import GHC.Driver.Ppr import Control.Monad.Trans.Except import Control.Monad.IO.Class import Util import Data.Char+import Data.List+import Data.List.NonEmpty qualified as NE import Data.List.Extra import Timing import Language.Preprocessor.Cpphs-import qualified Data.Map as Map import System.IO.Extra import Fixity import Extension import GHC.Data.FastString -import GHC.Hs+import GHC.Hs hiding (comments) import GHC.Types.SrcLoc+import GHC.Types.Fixity+import GHC.Types.Error+import GHC.Driver.Errors.Types+ import GHC.Utils.Error-import GHC.Utils.Outputable import GHC.Parser.Lexer hiding (context) import GHC.LanguageExtensions.Type-import GHC.Parser.Annotation import GHC.Driver.Session hiding (extensions) import GHC.Data.Bag+import Data.Generics.Uniplate.DataOnly import Language.Haskell.GhclibParserEx.GHC.Parser import Language.Haskell.GhclibParserEx.Fixity+import Language.Haskell.GhclibParserEx.GHC.Driver.Session+ import GHC.Util -- | What C pre processor should be used. data CppFlags- = NoCpp -- ^ No pre processing is done.- | CppSimple -- ^ Lines prefixed with @#@ are stripped.+ = CppSimple -- ^ Lines prefixed with @#@ are stripped. | Cpphs CpphsOptions -- ^ The @cpphs@ library is used. -- | Created with 'defaultParseFlags', used by 'parseModuleEx'.@@ -53,7 +60,7 @@ -- | Default value for 'ParseFlags'. defaultParseFlags :: ParseFlags-defaultParseFlags = ParseFlags NoCpp Nothing defaultExtensions [] defaultFixities+defaultParseFlags = ParseFlags CppSimple Nothing defaultExtensions [] defaultFixities -- | Given some fixities, add them to the existing fixities in 'ParseFlags'. parseFlagsAddFixities :: [FixityInfo] -> ParseFlags -> ParseFlags@@ -64,7 +71,6 @@ runCpp :: CppFlags -> FilePath -> String -> IO String-runCpp NoCpp _ x = pure x runCpp CppSimple _ x = pure $ unlines [if "#" `isPrefixOf` trimStart x then "" else x | x <- lines x] runCpp (Cpphs o) file x = dropLine <$> runCpphs o file x where@@ -83,35 +89,36 @@ } -- | Result of 'parseModuleEx', representing a parsed module.-data ModuleEx = ModuleEx {- ghcModule :: Located HsModule- , ghcAnnotations :: ApiAnns+newtype ModuleEx = ModuleEx {+ ghcModule :: Located (HsModule GhcPs) } --- | Extract a list of all of a parsed module's comments.-ghcComments :: ModuleEx -> [Located AnnotationComment]-ghcComments m =- map realToLoc $- concat (Map.elems $ apiAnnComments (ghcAnnotations m)) ++- apiAnnRogueComments (ghcAnnotations m)- where- -- TODO (2020-10-03, SF): This utility is repeated in- -- ApiAnnotation.hs. Consider doing something in- -- ghc-lib-parser-ex to clean this up.- realToLoc :: RealLocated a -> Located a- realToLoc (L r x) = L (RealSrcSpan r Nothing) x+-- | Extract a complete list of all the comments in a module.+ghcComments :: ModuleEx -> [LEpaComment]+ghcComments = universeBi . ghcModule +-- | Extract just the list of a modules' leading comments (pragmas).+modComments :: ModuleEx -> EpAnnComments+modComments = comments . hsmodAnn . hsmodExt . unLoc . ghcModule++-- | Extract comments associated with the first declaration of a module.+firstDeclComments :: ModuleEx -> EpAnnComments+firstDeclComments m =+ case hsmodDecls . unLoc . ghcModule $ m of+ [] -> EpaCommentsBalanced [] []+ L ann _ : _ -> comments ann+ -- | The error handler invoked when GHC parsing has failed. ghcFailOpParseModuleEx :: String -> FilePath -> String- -> (SrcSpan, GHC.Utils.Error.MsgDoc)+ -> (SrcSpan, SDoc) -> IO (Either ParseError ModuleEx) ghcFailOpParseModuleEx ppstr file str (loc, err) = do let pe = case loc of RealSrcSpan r _ -> context (srcSpanStartLine r) ppstr _ -> ""- msg = GHC.Utils.Outputable.showSDoc baseDynFlags err+ msg = GHC.Driver.Ppr.showSDoc baseDynFlags err pure $ Left $ ParseError loc msg pe -- GHC extensions to enable/disable given HSE parse flags.@@ -119,15 +126,15 @@ ghcExtensionsFromParseFlags ParseFlags{enabledExtensions=es, disabledExtensions=ds}= (es, ds) -- GHC fixities given HSE parse flags.-ghcFixitiesFromParseFlags :: ParseFlags -> [(String, Fixity)]+ghcFixitiesFromParseFlags :: ParseFlags -> [(String, GHC.Types.Fixity.Fixity)] ghcFixitiesFromParseFlags = map toFixity . fixities --- These next two functions get called frorm 'Config/Yaml.hs' for user+-- These next two functions get called from 'Config/Yaml.hs' for user -- defined hint rules. parseModeToFlags :: ParseFlags -> DynFlags parseModeToFlags parseMode =- flip lang_set (baseLanguage parseMode) $ foldl' xopt_unset (foldl' xopt_set baseDynFlags enable) disable+ flip lang_set (baseLanguage parseMode) $ foldl xopt_unset (foldl' xopt_set baseDynFlags enable) disable where (enable, disable) = ghcExtensionsFromParseFlags parseMode @@ -149,13 +156,26 @@ POk pst a -> POk pst $ applyFixities fixities a f@PFailed{} -> f --- | Create a 'ModuleEx' from GHC annotations and module tree. It--- is assumed the incoming parse module has not been adjusted to--- account for operator fixities (it uses the HLint default fixities).-createModuleEx :: ApiAnns -> Located HsModule -> ModuleEx-createModuleEx anns ast =- ModuleEx (applyFixities (fixitiesFromModule ast ++ map toFixity defaultFixities) ast) anns+-- | Create a 'ModuleEx' from a GHC module. It is assumed the incoming+-- parsed module has not been adjusted to account for operator+-- fixities (it uses the HLint default fixities).+createModuleEx :: Located (HsModule GhcPs) -> ModuleEx+createModuleEx = createModuleExWithFixities (map toFixity defaultFixities) +createModuleExWithFixities :: [(String, Fixity)] -> Located (HsModule GhcPs) -> ModuleEx+createModuleExWithFixities fixities ast =+ ModuleEx (applyFixities (fixitiesFromModule ast ++ fixities) ast)++impliedEnables :: Extension -> [Extension]+impliedEnables ext = case Data.List.lookup ext extensionImplications of+ Just exts -> ext : fst exts+ Nothing -> [ext]++impliedDisables :: Extension -> [Extension]+impliedDisables ext = case Data.List.lookup ext extensionImplications of+ Just exts -> ext : snd exts+ Nothing -> []+ -- | Parse a Haskell module. Applies the C pre processor, and uses -- best-guess fixity resolution if there are ambiguities. The -- filename @-@ is treated as @stdin@. Requires some flags (often@@ -172,7 +192,11 @@ Nothing | file == "-" -> liftIO getContentsUTF8 | otherwise -> liftIO $ readFileUTF8' file str <- pure $ dropPrefix "\65279" str -- Remove the BOM if it exists, see #130.- let enableDisableExts = ghcExtensionsFromParseFlags flags+ let (enable, disable) = ghcExtensionsFromParseFlags flags+ -- Enable/disable extensions and the extensions they imply.+ impliedEnabled = concatMap impliedEnables enable+ impliedDisabled = concatMap impliedDisables disable+ enableDisableExts = (impliedEnabled, impliedDisabled) -- Read pragmas for the first time. dynFlags <- withExceptT (parsePragmasErr str) $ ExceptT (parsePragmasIntoDynFlags baseDynFlags enableDisableExts file str) dynFlags <- pure $ lang_set dynFlags $ baseLanguage flags@@ -185,20 +209,14 @@ -- Done with pragmas. Proceed to parsing. case fileToModule file str dynFlags of POk s a -> do- let errs = bagToList . snd $ getMessages s dynFlags+ let errs = bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages s) if not $ null errs then- ExceptT $ parseFailureErr dynFlags str file str errs+ ExceptT $ parseFailureErr dynFlags str file str $ NE.fromList errs else do- let anns = ApiAnns {- apiAnnItems = Map.fromListWith (++) $ annotations s- , apiAnnEofPos = Nothing- , apiAnnComments = Map.fromListWith (++) $ annotations_comments s- , apiAnnRogueComments = comment_q s- } let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags- pure $ ModuleEx (applyFixities fixes a) anns+ pure $ ModuleEx (applyFixities fixes a) PFailed s ->- ExceptT $ parseFailureErr dynFlags str file str $ bagToList . snd $ getMessages s dynFlags+ ExceptT $ parseFailureErr dynFlags str file str $ NE.fromList . bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages s) where -- If parsing pragmas fails, synthesize a parse error from the -- error message.@@ -207,11 +225,9 @@ in ParseError (mkSrcSpan loc loc) msg src parseFailureErr dynFlags ppstr file str errs =- let errMsg = head errs+ let errMsg = NE.head errs loc = errMsgSpan errMsg- style = mkErrStyle (errMsgContext errMsg)- ctx = initSDocContext dynFlags style- doc = formatErrDoc ctx (errMsgDoc errMsg)+ doc = pprLocMsgEnvelopeDefault errMsg in ghcFailOpParseModuleEx ppstr file str (loc, doc) -- | Given a line number, and some source code, put bird ticks around the appropriate bit.
src/GHC/Util.hs view
@@ -41,7 +41,7 @@ import System.FilePath import Language.Preprocessor.Unlit -fileToModule :: FilePath -> String -> DynFlags -> ParseResult (Located HsModule)+fileToModule :: FilePath -> String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) fileToModule filename str flags = parseFile filename flags (if takeExtension filename /= ".lhs" then str else unlit filename str)
src/GHC/Util/ApiAnnotation.hs view
@@ -1,15 +1,29 @@+{-# LANGUAGE ImportQualifiedPost #-} module GHC.Util.ApiAnnotation (- comment, commentText, isCommentMultiline- , pragmas, flags, languagePragmas- , mkFlags, mkLanguagePragmas+ comment_+ , commentText+ , GHC.Util.ApiAnnotation.comments+ , isCommentMultiline+ , pragmas+ , flags+ , languagePragmas+ , mkFlags+ , mkLanguagePragmas+ , extensions ) where +import GHC.LanguageExtensions.Type (Extension) import GHC.Parser.Annotation+import GHC.Hs.DocString import GHC.Types.SrcLoc +import Language.Haskell.GhclibParserEx.GHC.Driver.Session+ import Control.Applicative import Data.List.Extra+import Data.Maybe+import Data.Set qualified as Set trimCommentStart :: String -> String trimCommentStart s@@ -26,44 +40,43 @@ trimCommentDelims = trimCommentEnd . trimCommentStart -- | A comment as a string.-comment :: Located AnnotationComment -> String-comment (L _ (AnnBlockComment s)) = s-comment (L _ (AnnLineComment s)) = s-comment (L _ (AnnDocOptions s)) = s-comment (L _ (AnnDocCommentNamed s)) = s-comment (L _ (AnnDocCommentPrev s)) = s-comment (L _ (AnnDocCommentNext s)) = s-comment (L _ (AnnDocSection _ s)) = s+comment_ :: LEpaComment -> String+comment_ (L _ (EpaComment (EpaDocComment ds ) _)) = renderHsDocString ds+comment_ (L _ (EpaComment (EpaDocOptions s) _)) = s+comment_ (L _ (EpaComment (EpaLineComment s) _)) = s+comment_ (L _ (EpaComment (EpaBlockComment s) _)) = s -- | The comment string with delimiters removed.-commentText :: Located AnnotationComment -> String-commentText = trimCommentDelims . comment+commentText :: LEpaComment -> String+commentText = trimCommentDelims . comment_ -isCommentMultiline :: Located AnnotationComment -> Bool-isCommentMultiline (L _ (AnnBlockComment _)) = True-isCommentMultiline _ = False+-- | Total replacement for the partial `GHC.Parser.Annotation.comments` field of+-- `EpAnn`+comments :: EpAnn ann -> EpAnnComments+comments EpAnn{ GHC.Parser.Annotation.comments = result } = result --- GHC parse trees don't contain pragmas. We work around this with--- (nasty) parsing of comments.+isCommentMultiline :: LEpaComment -> Bool+isCommentMultiline (L _ (EpaComment (EpaBlockComment _) _)) = True+isCommentMultiline _ = False --- Pragmas. Comments not associated with a span in the annotations--- that have the form @{-# ...#-}@.-pragmas :: ApiAnns -> [(Located AnnotationComment, String)]-pragmas anns =- -- 'ApiAnns' stores pragmas in reverse order to how they were+-- Pragmas have the form @{-# ...#-}@.+pragmas :: EpAnnComments -> [(LEpaComment, String)]+pragmas x =+ -- 'EpaAnnComments' stores pragmas in reverse order to how they were -- encountered in the source file with the last at the head of the -- list (makes sense when you think about it). reverse- [ (realToLoc c, s) |- c@(L _ (AnnBlockComment comm)) <- apiAnnRogueComments anns+ [ (c, s) |+ c@(L _ (EpaComment (EpaBlockComment comm) _)) <- priorComments x , let body = trimCommentDelims comm , Just rest <- [stripSuffix "#" =<< stripPrefix "#" body] , let s = trim rest ]- where- realToLoc :: RealLocated a -> Located a- realToLoc (L r x) = L (RealSrcSpan r Nothing) x +-- All the extensions defined to be used.+extensions :: EpAnnComments -> Set.Set Extension+extensions = Set.fromList . concatMap (mapMaybe readExtension . snd) . languagePragmas . pragmas+ -- Utility for a case insensitive prefix strip. stripPrefixCI :: String -> String -> Maybe String stripPrefixCI pref str =@@ -71,11 +84,9 @@ (str_pref, rest) = splitAt (length pref') str in if lower str_pref == pref' then Just rest else Nothing --- Flags. The first element of the pair is the (located) annotation--- comment that sets the flags enumerated in the second element of the--- pair.-flags :: [(Located AnnotationComment, String)]- -> [(Located AnnotationComment, [String])]+-- Flags. The first element of the pair is the comment that+-- sets the flags enumerated in the second element of the pair.+flags :: [(LEpaComment, String)] -> [(LEpaComment, [String])] flags ps = -- Old versions of GHC accepted 'OPTIONS' rather than 'OPTIONS_GHC' (but -- this is deprecated).@@ -86,19 +97,18 @@ -- Language pragmas. The first element of the -- pair is the (located) annotation comment that enables the--- pragmas enumerated by he second element of the pair.-languagePragmas :: [(Located AnnotationComment, String)]- -> [(Located AnnotationComment, [String])]+-- pragmas enumerated by the second element of the pair.+languagePragmas :: [(LEpaComment, String)] -> [(LEpaComment, [String])] languagePragmas ps = [(c, exts) | (c, s) <- ps , Just rest <- [stripPrefixCI "LANGUAGE " s] , let exts = map trim (splitOn "," rest)] -- Given a list of flags, make a GHC options pragma.-mkFlags :: SrcSpan -> [String] -> Located AnnotationComment-mkFlags loc flags =- L loc $ AnnBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")+mkFlags :: NoCommentsLocation -> [String] -> LEpaComment+mkFlags anc flags =+ L anc $ EpaComment (EpaBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")) (epaLocationRealSrcSpan anc) -mkLanguagePragmas :: SrcSpan -> [String] -> Located AnnotationComment-mkLanguagePragmas loc exts =- L loc $ AnnBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")+mkLanguagePragmas :: NoCommentsLocation -> [String] -> LEpaComment+mkLanguagePragmas anc exts =+ L anc $ EpaComment (EpaBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")) (epaLocationRealSrcSpan anc)
src/GHC/Util/Brackets.hs view
@@ -5,7 +5,7 @@ import GHC.Hs import GHC.Types.SrcLoc-import GHC.Types.Basic+import GHC.Types.SourceText import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Refact.Types @@ -20,7 +20,7 @@ needBracket :: Int -> a -> a -> Bool findType :: a -> RType -instance Brackets (LHsExpr GhcPs) where+instance Brackets (LocatedA (HsExpr GhcPs)) where -- When GHC parses a section in concrete syntax, it will produce an -- 'HsPar (Section[L|R])'. There is no concrete syntax that will -- result in a "naked" section. Consequently, given an expression,@@ -31,12 +31,13 @@ remParen (L _ (HsPar _ x)) = Just x remParen _ = Nothing - addParen e = noLoc $ HsPar noExtField e+ addParen = nlHsPar isAtom (L _ x) = case x of HsVar{} -> True HsUnboundVar{} -> True- HsRecFld{} -> True+ -- Only relevant for OverloadedRecordDot extension+ HsGetField{} -> True HsOverLabel{} -> True HsIPVar{} -> True -- Note that sections aren't atoms (but parenthesized sections are).@@ -47,10 +48,12 @@ RecordCon{} -> True RecordUpd{} -> True ArithSeq{}-> True- HsBracket{} -> True+ HsTypedBracket{} -> True+ HsUntypedBracket{} -> True -- HsSplice might be $foo, where @($foo) would require brackets, -- but in that case the $foo is a type, so we can still mark Splice as atomic- HsSpliceE{} -> True+ HsTypedSplice{} -> True+ HsUntypedSplice{} -> True HsOverLit _ x | not $ isNegativeOverLit x -> True HsLit _ x | not $ isNegativeLit x -> True _ -> False@@ -97,22 +100,26 @@ -- -- (f \x -> x) *> ... -- (f do x) *> ...-isAtomOrApp :: LHsExpr GhcPs -> Bool+isAtomOrApp :: LocatedA (HsExpr GhcPs) -> Bool isAtomOrApp x | isAtom x = True isAtomOrApp (L _ (HsApp _ _ x)) = isAtomOrApp x isAtomOrApp _ = False -instance Brackets (Located (Pat GhcPs)) where+instance Brackets (LocatedA (Pat GhcPs)) where remParen (L _ (ParPat _ x)) = Just x remParen _ = Nothing- addParen e = noLoc $ ParPat noExtField e + addParen = nlParPat+ isAtom (L _ x) = case x of ParPat{} -> True TuplePat{} -> True ListPat{} -> True- ConPat _ _ RecCon{} -> True- ConPat _ _ (PrefixCon []) -> True+ -- This is technically atomic, but lots of people think it shouldn't be+ ConPat _ _ RecCon{} -> False+ -- Before we only checked args, but not type args, resulting in a+ -- false positive for things like (Proxy @a)+ ConPat _ _ (PrefixCon [] []) -> True VarPat{} -> True WildPat{} -> True SumPat{} -> True@@ -139,10 +146,10 @@ findType _ = Pattern -instance Brackets (LHsType GhcPs) where+instance Brackets (LocatedA (HsType GhcPs)) where remParen (L _ (HsParTy _ x)) = Just x remParen _ = Nothing- addParen e = noLoc $ HsParTy noExtField e+ addParen e = noLocA $ HsParTy noAnn e isAtom (L _ x) = case x of HsParTy{} -> True
src/GHC/Util/DynFlags.hs view
@@ -1,23 +1,14 @@ module GHC.Util.DynFlags (initGlobalDynFlags, baseDynFlags) where import GHC.Driver.Session-import GHC.LanguageExtensions.Type-import Data.List.Extra import Language.Haskell.GhclibParserEx.GHC.Settings.Config +-- The list of default enabled extensions is empty. This is because:+-- the extensions to enable/disable are set exclusively in+-- 'parsePragmasIntoDynFlags' based solely on the parse flags+-- (and source level annotations). baseDynFlags :: DynFlags-baseDynFlags =- -- The list of default enabled extensions is empty except for- -- 'TemplateHaskellQuotes'. This is because:- -- * The extensions to enable/disable are set exclusively in- -- 'parsePragmasIntoDynFlags' based solely on HSE parse flags- -- (and source level annotations);- -- * 'TemplateHaskellQuotes' is not a known HSE extension but IS- -- needed if the GHC parse is to succeed for the unit-test at- -- hlint.yaml:860- let enable = [TemplateHaskellQuotes]- in foldl' xopt_set (defaultDynFlags fakeSettings fakeLlvmConfig) enable-+baseDynFlags = defaultDynFlags fakeSettings initGlobalDynFlags :: IO () initGlobalDynFlags = setUnsafeGlobalDynFlags baseDynFlags
src/GHC/Util/FreeVars.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-}@@ -12,14 +13,13 @@ import GHC.Types.Name import GHC.Hs import GHC.Types.SrcLoc-import GHC.Data.Bag (bagToList) import Data.Generics.Uniplate.DataOnly import Data.Monoid import Data.Semigroup import Data.List.Extra import Data.Set (Set)-import qualified Data.Set as Set+import Data.Set qualified as Set import Prelude ( ^+ ) :: Set OccName -> Set OccName -> Set OccName@@ -44,7 +44,7 @@ mconcat vs = Vars (Set.unions $ map bound vs) (Set.unions $ map free vs) -- A type `a` is a model of `AllVars a` if exists a function--- `allVars` for producing a pair of the bound and free varaiable+-- `allVars` for producing a pair of the bound and free variable -- sets in a value of `a`. class AllVars a where -- | Return the variables, erring on the side of more free@@ -52,7 +52,7 @@ allVars :: a -> Vars -- A type `a` is a model of `FreeVars a` if exists a function--- `freeVars` for producing a set of free varaiable of a value of+-- `freeVars` for producing a set of free variables of a value of -- `a`. class FreeVars a where -- | Return the variables, erring on the side of more free@@ -90,33 +90,48 @@ bb = allVars b -- Get an `OccName` out of a reader name.-unqualNames :: Located RdrName -> [OccName]+unqualNames :: LocatedN RdrName -> [OccName] unqualNames (L _ (Unqual x)) = [x] unqualNames (L _ (Exact x)) = [nameOccName x] unqualNames _ = [] -instance FreeVars (LHsExpr GhcPs) where+instance FreeVars (LocatedA (HsExpr GhcPs)) where freeVars (L _ (HsVar _ x)) = Set.fromList $ unqualNames x -- Variable.- freeVars (L _ (HsUnboundVar _ x)) = Set.fromList [x] -- Unbound variable; also used for "holes".- freeVars (L _ (HsLam _ mg)) = free (allVars mg) -- Lambda abstraction. Currently always a single match.- freeVars (L _ (HsLamCase _ MG{mg_alts=(L _ ms)})) = free (allVars ms) -- Lambda case+ freeVars (L _ (HsUnboundVar _ x)) = Set.fromList [rdrNameOcc x] -- Unbound variable; also used for "holes".+ freeVars (L _ (HsLam _ LamSingle mg)) = free (allVars mg) -- Lambda abstraction. Currently always a single match.+ freeVars (L _ (HsLam _ _ MG{mg_alts=(L _ ms)})) = free (allVars ms) -- Lambda case freeVars (L _ (HsCase _ of_ MG{mg_alts=(L _ ms)})) = freeVars of_ ^+ free (allVars ms) -- Case expr. freeVars (L _ (HsLet _ binds e)) = inFree binds e -- Let (rec).- freeVars (L _ (HsDo _ ctxt (L _ stmts))) = free (allVars stmts) -- Do block.- freeVars (L _ (RecordCon _ _ (HsRecFields flds _))) = Set.unions $ map freeVars flds -- Record construction.- freeVars (L _ (RecordUpd _ e flds)) = Set.unions $ freeVars e : map freeVars flds -- Record update.+ freeVars (L _ (HsDo _ ctxt (L _ stmts))) = snd $ foldl' alg mempty stmts -- Do block.+ where+ alg ::+ (Set OccName, Set OccName) ->+ LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))) ->+ (Set OccName, Set OccName)+ alg (accBound0, accFree0) stmt = (accBound, accFree)+ where+ accBound =+ accBound0+ ^+ ( case stmt of+ L _ (BindStmt _ pat _) -> bound (allVars pat)+ L _ (LetStmt _ binds) -> bound (allVars binds)+ _ -> mempty+ )+ accFree = accFree0 ^+ (free (allVars stmt) ^- accBound0)+ freeVars (L _ (RecordCon _ _ (HsRecFields _ flds _))) = Set.unions $ map freeVars flds -- Record construction.+ freeVars (L _ (RecordUpd _ e flds)) =+ case flds of+ RegularRecUpdFields _ fs -> Set.unions $ freeVars e : map freeVars fs+ OverloadedRecUpdFields _ ps -> Set.unions $ freeVars e : map freeVars ps freeVars (L _ (HsMultiIf _ grhss)) = free (allVars grhss) -- Multi-way if.- freeVars (L _ (HsBracket _ (ExpBr _ e))) = freeVars e- freeVars (L _ (HsBracket _ (VarBr _ _ v))) = Set.fromList [occName v]+ freeVars (L _ (HsTypedBracket _ e)) = freeVars e+ freeVars (L _ (HsUntypedBracket _ (ExpBr _ e))) = freeVars e+ freeVars (L _ (HsUntypedBracket _ (VarBr _ _ v))) = Set.fromList [occName (unLoc v)] - freeVars (L _ HsConLikeOut{}) = mempty -- After typechecker.- freeVars (L _ HsRecFld{}) = mempty -- Variable pointing to a record selector. freeVars (L _ HsOverLabel{}) = mempty -- Overloaded label. The id of the in-scope fromLabel. freeVars (L _ HsIPVar{}) = mempty -- Implicit parameter. freeVars (L _ HsOverLit{}) = mempty -- Overloaded literal. freeVars (L _ HsLit{}) = mempty -- Simple literal.- freeVars (L _ HsRnBracketOut{}) = mempty -- Renamer produces these.- freeVars (L _ HsTcBracketOut{}) = mempty -- Typechecker produces these. -- freeVars (e@(L _ HsAppType{})) = freeVars $ children e -- Visible type application e.g. f @ Int x y. -- freeVars (e@(L _ HsApp{})) = freeVars $ children e -- Application.@@ -148,27 +163,27 @@ freeVars e = freeVars $ children e -instance FreeVars (LHsTupArg GhcPs) where- freeVars (L _ (Present _ args)) = freeVars args+instance FreeVars (HsTupArg GhcPs) where+ freeVars (Present _ args) = freeVars args freeVars _ = mempty -instance FreeVars (LHsRecField GhcPs (LHsExpr GhcPs)) where- freeVars o@(L _ (HsRecField x _ True)) = Set.singleton $ occName $ unLoc $ rdrNameFieldOcc $ unLoc x -- a pun- freeVars o@(L _ (HsRecField _ x _)) = freeVars x+instance FreeVars (LocatedA (HsFieldBind (LocatedA (FieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where+ freeVars o@(L _ (HsFieldBind _ x _ True)) = Set.singleton $ occName $ unLoc $ foLabel $ unLoc x -- a pun+ freeVars o@(L _ (HsFieldBind _ _ x _)) = freeVars x -instance FreeVars (LHsRecUpdField GhcPs) where- freeVars (L _ (HsRecField _ x _)) = freeVars x+instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) (LocatedA (HsExpr GhcPs)))) where+ freeVars (L _ (HsFieldBind _ _ x _)) = freeVars x -instance AllVars (Located (Pat GhcPs)) where+instance AllVars (LocatedA (Pat GhcPs)) where allVars (L _ (VarPat _ (L _ x))) = Vars (Set.singleton $ rdrNameOcc x) Set.empty -- Variable pattern.- allVars (L _ (AsPat _ n x)) = allVars (noLoc $ VarPat noExtField n :: LPat GhcPs) <> allVars x -- As pattern.- allVars (L _ (ConPat _ _ (RecCon (HsRecFields flds _)))) = allVars flds- allVars (L _ (NPlusKPat _ n _ _ _ _)) = allVars (noLoc $ VarPat noExtField n :: LPat GhcPs) -- n+k pattern.+ allVars (L _ (AsPat _ n x)) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) <> allVars x -- As pattern.+ allVars (L _ (ConPat _ _ (RecCon (HsRecFields _ flds _)))) = allVars flds+ allVars (L _ (NPlusKPat _ n _ _ _ _)) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) -- n+k pattern. allVars (L _ (ViewPat _ e p)) = freeVars_ e <> allVars p -- View pattern.- allVars (L _ WildPat{}) = mempty -- Wildcard pattern. allVars (L _ LitPat{}) = mempty -- Literal pattern. allVars (L _ NPat{}) = mempty -- Natural pattern.+ allVars (L _ InvisPat {}) = mempty -- since ghc-9.10.1 -- allVars p@SplicePat{} = allVars $ children p -- Splice pattern (includes quasi-quotes). -- allVars p@SigPat{} = allVars $ children p -- Pattern with a type signature.@@ -182,58 +197,57 @@ allVars p = allVars $ children p -instance AllVars (LHsRecField GhcPs (Located (Pat GhcPs))) where- allVars (L _ (HsRecField _ x _)) = allVars x+instance AllVars (LocatedA (HsFieldBind (LocatedA (FieldOcc GhcPs)) (LocatedA (Pat GhcPs)))) where+ allVars (L _ (HsFieldBind _ _ x _)) = allVars x -instance AllVars (LStmt GhcPs (LHsExpr GhcPs)) where+instance AllVars (LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))) where allVars (L _ (LastStmt _ expr _ _)) = freeVars_ expr -- The last stmt of a ListComp, MonadComp, DoExpr,MDoExpr. allVars (L _ (BindStmt _ pat expr)) = allVars pat <> freeVars_ expr -- A generator e.g. x <- [1, 2, 3]. allVars (L _ (BodyStmt _ expr _ _)) = freeVars_ expr -- A boolean guard e.g. even x. allVars (L _ (LetStmt _ binds)) = allVars binds -- A local declaration e.g. let y = x + 1- allVars (L _ (TransStmt _ _ stmts _ using by _ _ fmap_)) = allVars stmts <> freeVars_ using <> maybe mempty freeVars_ by <> freeVars_ (noLoc fmap_ :: Located (HsExpr GhcPs)) -- Apply a function to a list of statements in order.- allVars (L _ (RecStmt _ stmts _ _ _ _ _)) = allVars stmts -- A recursive binding for a group of arrows.-- allVars (L _ ApplicativeStmt{}) = mempty -- Generated by the renamer.+ allVars (L _ (TransStmt _ _ stmts _ using by _ _ fmap_)) = allVars stmts <> freeVars_ using <> maybe mempty freeVars_ by <> freeVars_ (noLocA fmap_ :: LocatedA (HsExpr GhcPs)) -- Apply a function to a list of statements in order.+ allVars (L _ (RecStmt _ stmts _ _ _ _ _)) = allVars (unLoc stmts) -- A recursive binding for a group of arrows. allVars (L _ ParStmt{}) = mempty -- Parallel list thing. Come back to it. -instance AllVars (LHsLocalBinds GhcPs) where- allVars (L _ (HsValBinds _ (ValBinds _ binds _))) = allVars (bagToList binds) -- Value bindings.- allVars (L _ (HsIPBinds _ (IPBinds _ binds))) = allVars binds -- Implicit parameter bindings.- allVars (L _ EmptyLocalBinds{}) = mempty -- The case of no local bindings (signals the empty `let` or `where` clause).+instance AllVars (HsLocalBinds GhcPs) where+ allVars (HsValBinds _ (ValBinds _ binds _)) = allVars binds -- Value bindings.+ allVars (HsIPBinds _ (IPBinds _ binds)) = allVars binds -- Implicit parameter bindings.+ allVars EmptyLocalBinds{} = mempty -- The case of no local bindings (signals the empty `let` or `where` clause).+ allVars _ = mempty -- extension points -instance AllVars (LIPBind GhcPs) where+instance AllVars (LocatedA (IPBind GhcPs)) where allVars (L _ (IPBind _ _ e)) = freeVars_ e -instance AllVars (LHsBind GhcPs) where- allVars (L _ FunBind{fun_id=n, fun_matches=MG{mg_alts=(L _ ms)}}) = allVars (noLoc $ VarPat noExtField n :: LPat GhcPs) <> allVars ms -- Function bindings and simple variable bindings e.g. f x = e, f !x = 3, f = e, !x = e, x `f` y = e+instance AllVars (LocatedA (HsBindLR GhcPs GhcPs)) where+ allVars (L _ FunBind{fun_id=n, fun_matches=MG{mg_alts=(L _ ms)}}) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) <> allVars ms -- Function bindings and simple variable bindings e.g. f x = e, f !x = 3, f = e, !x = e, x `f` y = e allVars (L _ PatBind{pat_lhs=n, pat_rhs=grhss}) = allVars n <> allVars grhss -- Ctor patterns and some other interesting cases e.g. Just x = e, (x) = e, x :: Ty = e. allVars (L _ (PatSynBind _ PSB{})) = mempty -- Come back to it.- allVars (L _ VarBind{}) = mempty -- Typechecker.- allVars (L _ AbsBinds{}) = mempty -- Not sure but I think renamer. -instance AllVars (MatchGroup GhcPs (LHsExpr GhcPs)) where- allVars (MG _ _alts@(L _ alts) _) = inVars (foldMap (allVars . m_pats) ms) (allVars (map m_grhss ms))+instance AllVars (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where+ allVars (MG _ _alts@(L _ alts)) = foldMap (\m -> inVars (allVars ((unLoc . m_pats) m)) (allVars (m_grhss m))) ms where ms = map unLoc alts -instance AllVars (LMatch GhcPs (LHsExpr GhcPs)) where- allVars (L _ (Match _ FunRhs {mc_fun=name} pats grhss)) = allVars (noLoc $ VarPat noExtField name :: LPat GhcPs) <> allVars pats <> allVars grhss -- A pattern matching on an argument of a function binding.- allVars (L _ (Match _ (StmtCtxt ctxt) pats grhss)) = allVars ctxt <> allVars pats <> allVars grhss -- Pattern of a do-stmt, list comprehension, pattern guard etc.- allVars (L _ (Match _ _ pats grhss)) = inVars (allVars pats) (allVars grhss) -- Everything else.+instance AllVars (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where+ allVars (L _ (Match _ FunRhs {mc_fun=name} pats grhss)) = allVars (noLocA $ VarPat noExtField name :: LocatedA (Pat GhcPs)) <> (allVars . unLoc) pats <> allVars grhss -- A pattern matching on an argument of a function binding.+ allVars (L _ (Match _ (StmtCtxt ctxt) pats grhss)) = allVars ctxt <> (allVars . unLoc) pats <> allVars grhss -- Pattern of a do-stmt, list comprehension, pattern guard etc.+ allVars (L _ (Match _ _ pats grhss)) = inVars ((allVars . unLoc) pats) (allVars grhss) -- Everything else. -instance AllVars (HsStmtContext GhcPs) where- allVars (PatGuard FunRhs{mc_fun=n}) = allVars (noLoc $ VarPat noExtField n :: LPat GhcPs)+instance AllVars (HsStmtContext (GenLocated SrcSpanAnnN RdrName)) where+ allVars (PatGuard FunRhs{mc_fun=n}) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) allVars ParStmtCtxt{} = mempty -- Come back to it. allVars TransStmtCtxt{} = mempty -- Come back to it.+ allVars _ = mempty -instance AllVars (GRHSs GhcPs (LHsExpr GhcPs)) where+instance AllVars (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where allVars (GRHSs _ grhss binds) = inVars binds (mconcatMap allVars grhss) -instance AllVars (LGRHS GhcPs (LHsExpr GhcPs)) where+instance AllVars (LocatedAn NoEpAnns (GRHS GhcPs (LocatedA (HsExpr GhcPs)))) where allVars (L _ (GRHS _ guards expr)) = Vars (bound gs) (free gs ^+ (freeVars expr ^- bound gs)) where gs = allVars guards -instance AllVars (LHsDecl GhcPs) where- allVars (L l (ValD _ bind)) = allVars (L l bind :: LHsBind GhcPs)+instance AllVars (LocatedA (HsDecl GhcPs)) where+ allVars (L l (ValD _ bind)) = allVars (L l bind :: LocatedA (HsBindLR GhcPs GhcPs))+ allVars _ = mempty vars :: FreeVars a => a -> [String]
src/GHC/Util/HsExpr.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}@@ -20,14 +21,14 @@ import GHC.Data.FastString import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence-import GHC.Data.Bag(bagToList) import GHC.Util.Brackets import GHC.Util.FreeVars import GHC.Util.View -import Control.Applicative+import Control.Monad.Trans.Class import Control.Monad.Trans.State+import Control.Monad.Trans.Writer.CPS import Data.Data import Data.Generics.Uniplate.DataOnly@@ -35,9 +36,9 @@ import Data.Tuple.Extra import Data.Maybe -import Refact (substVars, toSS)+import Refact (substVars, toSSA) import Refact.Types hiding (SrcSpan, Match)-import qualified Refact.Types as R (SrcSpan)+import Refact.Types qualified as R (SrcSpan) import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr@@ -47,7 +48,7 @@ -- | 'dotApp a b' makes 'a . b'. dotApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs-dotApp x y = noLoc $ OpApp noExtField x (noLoc $ HsVar noExtField (noLoc $ mkVarUnqual (fsLit "."))) y+dotApp x y = noLocA $ OpApp noExtField x (noLocA $ HsVar noExtField (noLocA $ mkVarUnqual (fsLit "."))) y dotApps :: [LHsExpr GhcPs] -> LHsExpr GhcPs dotApps [] = error "GHC.Util.HsExpr.dotApps', does not work on an empty list"@@ -56,7 +57,7 @@ -- | @lambda [p0, p1..pn] body@ makes @\p1 p1 .. pn -> body@ lambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs-lambda vs body = noLoc $ HsLam noExtField (MG noExtField (noLoc [noLoc $ Match noExtField LambdaExpr vs (GRHSs noExtField [noLoc $ GRHS noExtField [] body] (noLoc $ EmptyLocalBinds noExtField))]) Generated)+lambda vs body = noLocA $ HsLam noAnn LamSingle (MG (Generated OtherExpansion DoPmc) (noLocA [noLocA $ Match noExtField (LamAlt LamSingle) (L noSpanAnchor vs) (GRHSs emptyComments [noLocA $ GRHS noAnn [] body] (EmptyLocalBinds noExtField))])) -- | 'paren e' wraps 'e' in parens if 'e' is non-atomic. paren :: LHsExpr GhcPs -> LHsExpr GhcPs@@ -70,7 +71,7 @@ apps :: [LHsExpr GhcPs] -> LHsExpr GhcPs-apps = foldl1' mkApp where mkApp x y = noLoc (HsApp noExtField x y)+apps = foldl1' mkApp where mkApp x y = noLocA (HsApp noExtField x y) fromApps :: LHsExpr GhcPs -> [LHsExpr GhcPs] fromApps (L _ (HsApp _ x y)) = fromApps x ++ [y]@@ -84,17 +85,20 @@ universeApps x = x : concatMap universeApps (childrenApps x) descendAppsM :: Monad m => (LHsExpr GhcPs -> m (LHsExpr GhcPs)) -> LHsExpr GhcPs -> m (LHsExpr GhcPs)-descendAppsM f (L l (HsApp _ x y)) = liftA2 (\x y -> L l $ HsApp noExtField x y) (descendAppsM f x) (f y)+descendAppsM f (L l (HsApp _ x y)) = (\x y -> L l $ HsApp noExtField x y) <$> descendAppsM f x <*> f y descendAppsM f x = descendM f x transformAppsM :: Monad m => (LHsExpr GhcPs -> m (LHsExpr GhcPs)) -> LHsExpr GhcPs -> m (LHsExpr GhcPs) transformAppsM f x = f =<< descendAppsM (transformAppsM f) x descendIndex :: Data a => (Int -> a -> a) -> a -> a-descendIndex f x = flip evalState 0 $ flip descendM x $ \y -> do+descendIndex f = fst . descendIndex' (\x a -> writer (f x a, ()))++descendIndex' :: (Data a, Monoid w) => (Int -> a -> Writer w a) -> a -> (a, w)+descendIndex' f x = runWriter $ flip evalStateT 0 $ flip descendM x $ \y -> do i <- get modify (+1)- pure $ f i y+ lift $ f i y -- There are differences in pretty-printing between GHC and HSE. This -- version never removes brackets.@@ -112,16 +116,15 @@ -- A list of application, with any necessary brackets. appsBracket :: [LHsExpr GhcPs] -> LHsExpr GhcPs appsBracket = foldl1 mkApp- where mkApp x y = rebracket1 (noLoc $ HsApp noExtField x y)-+ where mkApp x y = rebracket1 (noLocA $ HsApp noExtField x y) simplifyExp :: LHsExpr GhcPs -> LHsExpr GhcPs -- Replace appliciations 'f $ x' with 'f (x)'.-simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp noExtField x (noLoc (HsPar noExtField y)))-simplifyExp e@(L _ (HsLet _ (L _ (HsValBinds _ (ValBinds _ binds []))) z)) =+simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp noExtField x (nlHsPar y))+simplifyExp e@(L _ (HsLet _ ((HsValBinds _ (ValBinds _ binds []))) z)) = -- An expression of the form, 'let x = y in z'.- case bagToList binds of- [L _ (FunBind _ _ (MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _) [] (GRHSs _[L _ (GRHS _ [] y)] (L _ (EmptyLocalBinds _))))]) _) _)]+ case binds of+ [L _ (FunBind _ _ (MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _ _) (L _ []) (GRHSs _ [L _ (GRHS _ [] y)] ((EmptyLocalBinds _))))])))] -- If 'x' is not in the free variables of 'y', beta-reduce to -- 'z[(y)/x]'. | occNameStr x `notElem` vars y && length [() | Unqual a <- universeBi z, a == rdrNameOcc x] <= 1 ->@@ -136,7 +139,6 @@ niceDotApp (L _ (HsVar _ (L _ r))) b | occNameStr r == "$" = b niceDotApp a b = dotApp a b - -- Generate a lambda expression but prettier if possible. niceLambda :: [String] -> LHsExpr GhcPs -> LHsExpr GhcPs niceLambda ss e = fst (niceLambdaR ss e)-- We don't support refactorings yet.@@ -174,7 +176,7 @@ , vars e `disjoint` [v] , L _ (HsVar _ (L _ fname)) <- f , isSymOcc $ rdrNameOcc fname- = let res = noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField e f+ = let res = nlHsPar $ noLocA $ SectionL noExtField e f in (res, \s -> [Replace Expr s [] (unsafePrettyPrint res)]) -- @\vs v -> f x v@ ==> @\vs -> f x@@@ -195,7 +197,7 @@ -- lexeme, or it all gets too complex). niceLambdaR [x] (view -> App2 op@(L _ (HsVar _ (L _ tag))) l r) | isLexeme r, view l == Var_ x, x `notElem` vars r, allowRightSection (occNameStr tag) =- let e = rebracket1 $ addParen (noLoc $ SectionR noExtField op r)+ let e = rebracket1 $ addParen (noLocA $ SectionR noExtField op r) in (e, \s -> [Replace Expr s [] (unsafePrettyPrint e)]) -- Rewrite (1) @\x -> f (b x)@ as @f . b@, (2) @\x -> f $ b x@ as @f . b@. niceLambdaR [x] y@@ -214,7 +216,7 @@ factor _ = Nothing mkRefact :: [LHsExpr GhcPs] -> R.SrcSpan -> Refactoring R.SrcSpan mkRefact subts s =- let tempSubts = zipWith (\a b -> (a, toSS b)) substVars subts+ let tempSubts = zipWith (\a b -> (a, toSSA b)) substVars subts template = dotApps (map (strToVar . fst) tempSubts) in Replace Expr s tempSubts (unsafePrettyPrint template) -- Rewrite @\x y -> x + y@ as @(+)@.@@ -224,31 +226,32 @@ niceLambdaR [x, y] (view -> App2 op (view -> Var_ y1) (view -> Var_ x1)) | x == x1, y == y1, vars op `disjoint` [x, y] = ( gen op- , \s -> [Replace Expr s [("x", toSS op)] (unsafePrettyPrint $ gen (strToVar "x"))]+ , \s -> [Replace Expr s [("x", toSSA op)] (unsafePrettyPrint $ gen (strToVar "x"))] ) where- gen = noLoc . HsApp noExtField (strToVar "flip")+ gen :: LHsExpr GhcPs -> LHsExpr GhcPs+ gen = noLocA . HsApp noExtField (strToVar "flip") . if isAtom op then id else addParen -- We're done factoring, but have no variables left, so we shouldn't make a lambda. -- @\ -> e@ ==> @e@-niceLambdaR [] e = (e, \s -> [Replace Expr s [("a", toSS e)] "a"])+niceLambdaR [] e = (e, \s -> [Replace Expr s [("a", toSSA e)] "a"]) -- Base case. Just a good old fashioned lambda. niceLambdaR ss e =- let grhs = noLoc $ GRHS noExtField [] e :: LGRHS GhcPs (LHsExpr GhcPs)- grhss = GRHSs {grhssExt = noExtField, grhssGRHSs=[grhs], grhssLocalBinds=noLoc $ EmptyLocalBinds noExtField}- match = noLoc $ Match {m_ext=noExtField, m_ctxt=LambdaExpr, m_pats=map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs)- matchGroup = MG {mg_ext=noExtField, mg_origin=Generated, mg_alts=noLoc [match]}- in (noLoc $ HsLam noExtField matchGroup, const [])+ let grhs = noLocA $ GRHS noAnn [] e :: LGRHS GhcPs (LHsExpr GhcPs)+ grhss = GRHSs {grhssExt = emptyComments, grhssGRHSs=[grhs], grhssLocalBinds=EmptyLocalBinds noExtField}+ match = noLocA $ Match {m_ext=noExtField, m_ctxt=LamAlt LamSingle, m_pats=noLocA $ map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs)+ matchGroup = MG {mg_ext=Generated OtherExpansion SkipPmc, mg_alts=noLocA [match]}+ in (noLocA $ HsLam noAnn LamSingle matchGroup, const []) -- 'case' and 'if' expressions have branches, nothing else does (this -- doesn't consider 'HsMultiIf' perhaps it should?). replaceBranches :: LHsExpr GhcPs -> ([LHsExpr GhcPs], [LHsExpr GhcPs] -> LHsExpr GhcPs)-replaceBranches (L l (HsIf _ a b c)) = ([b, c], \[b, c] -> L l (HsIf noExtField a b c))+replaceBranches (L l (HsIf _ a b c)) = ([b, c], \[b, c] -> L l (HsIf noAnn a b c)) -replaceBranches (L s (HsCase _ a (MG _ (L l bs) FromSource))) =- (concatMap f bs, \xs -> L s (HsCase noExtField a (MG noExtField (L l (g bs xs)) Generated)))+replaceBranches (L s (HsCase _ a (MG FromSource (L l bs)))) =+ (concatMap f bs, L s . HsCase noAnn a . MG (Generated OtherExpansion SkipPmc). L l . g bs) where f :: LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs] f (L _ (Match _ CaseAlt _ (GRHSs _ xs _))) = [x | (L _ (GRHS _ _ x)) <- xs]@@ -256,7 +259,7 @@ g :: [LMatch GhcPs (LHsExpr GhcPs)] -> [LHsExpr GhcPs] -> [LMatch GhcPs (LHsExpr GhcPs)] g (L s1 (Match _ CaseAlt a (GRHSs _ ns b)) : rest) xs =- L s1 (Match noExtField CaseAlt a (GRHSs noExtField [L a (GRHS noExtField gs x) | (L a (GRHS _ gs _), x) <- zip ns as] b)) : g rest bs+ L s1 (Match noExtField CaseAlt a (GRHSs emptyComments [L a (GRHS noAnn gs x) | (L a (GRHS _ gs _), x) <- zip ns as] b)) : g rest bs where (as, bs) = splitAt (length ns) xs g [] [] = [] g _ _ = error "GHC.Util.HsExpr.replaceBranches': internal invariant failed, lists are of differing lengths"@@ -271,37 +274,45 @@ | isDotApp parent, isDotApp child, i == 2 = False | otherwise = needBracket i parent child -transformBracketOld :: (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)) -> LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs)+transformBracketOld :: (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs))+ -> LHsExpr GhcPs+ -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String])) transformBracketOld op = first snd . g where g = first f . descendBracketOld g f x = maybe (False, x) (True, ) (op x) -- Descend, and if something changes then add/remove brackets--- appropriately. Returns (suggested replacement, refactor template).--- Whenever a bracket is added to the suggested replacement, a--- corresponding bracket is added to the refactor template.-descendBracketOld :: (LHsExpr GhcPs -> ((Bool, LHsExpr GhcPs), LHsExpr GhcPs))- -> LHsExpr GhcPs- -> (LHsExpr GhcPs, LHsExpr GhcPs)-descendBracketOld op x = (descendIndex g1 x, descendIndex g2 x)+-- appropriately. Returns (suggested replacement, (refactor template, no bracket vars)),+-- where "no bracket vars" is a list of substitution variables which, when expanded,+-- should have the brackets stripped.+descendBracketOld :: (LHsExpr GhcPs -> ((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String])))+ -> LHsExpr GhcPs+ -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))+descendBracketOld op x = (descendIndex g1 x, descendIndex' g2 x) where- g i y = if a then (f1 i b z, f2 i b z) else (b, z)- where ((a, b), z) = op y+ g i y = if a then (f1 i b z w, f2 i b z w) else (b, (z, w))+ where ((a, b), (z, w)) = op y - g1 = (fst .) . g- g2 = (snd .) . g+ g1 a b = fst (g a b)+ g2 a b = writer $ snd (g a b) - f i (L _ (HsPar _ y)) z- | not $ needBracketOld i x y = (y, z)- f i y z- | needBracketOld i x y = (addParen y, addParen z)+ f i (L _ (HsPar _ y)) z w+ | not $ needBracketOld i x y = (y, removeBracket z)+ where+ -- If the template expr is a Var, record it so that we can remove the brackets+ -- later when expanding it. Otherwise, remove the enclosing brackets (if any).+ removeBracket = \case+ var@(L _ HsVar{}) -> (z, varToStr var : w)+ other -> (fromParen z, w)+ f i y z w+ | needBracketOld i x y = (addParen y, (addParen z, w)) -- https://github.com/mpickering/apply-refact/issues/7- | isOp y = (y, addParen z)- f _ y z = (y, z)+ | isOp y = (y, (addParen z, w))+ f _ y z w = (y, (z, w)) - f1 = ((fst .) .) . f- f2 = ((snd .) .) . f+ f1 a b c d = fst (f a b c d)+ f2 a b c d = snd (f a b c d) isOp = \case L _ (HsVar _ (L _ name)) -> isSymbolRdrName name
src/GHC/Util/Scope.hs view
@@ -1,5 +1,5 @@ -{-# LANGUAGE ViewPatterns #-}+{-# Language ViewPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Util.Scope (@@ -9,17 +9,18 @@ import GHC.Hs import GHC.Types.SrcLoc-import GHC.Types.Basic-import GHC.Unit.Module+import GHC.Types.SourceText import GHC.Data.FastString import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence+import GHC.Types.PkgQual import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable import Data.List.Extra import Data.Maybe+import Data.Bifunctor -- A scope is a list of import declarations. newtype Scope = Scope [LImportDecl GhcPs]@@ -29,20 +30,25 @@ show (Scope x) = unsafePrettyPrint x -- Create a 'Scope from a module's import declarations.-scopeCreate :: HsModule -> Scope+scopeCreate :: HsModule GhcPs -> Scope scopeCreate xs = Scope $ [prelude | not $ any isPrelude res] ++ res where -- Package qualifier of an import declaration. pkg :: LImportDecl GhcPs -> Maybe StringLiteral- pkg (L _ x) = ideclPkgQual x+ pkg (L _ x) =+ case ideclPkgQual x of+ RawPkgQual s -> Just s+ NoRawPkgQual -> Nothing - -- The import declaraions contained by the module 'xs'.+ -- The import declarations contained by the module 'xs'. res :: [LImportDecl GhcPs]- res = [x | x <- hsmodImports xs , pkg x /= Just (StringLiteral NoSourceText (fsLit "hint"))]+ res = [x | x <- hsmodImports xs+ , pkg x /= Just (StringLiteral NoSourceText (fsLit "hint") Nothing)+ ] - -- Mock up an import declaraion corresponding to 'import Prelude'.+ -- Mock up an import declaration corresponding to 'import Prelude'. prelude :: LImportDecl GhcPs- prelude = noLoc $ simpleImportDecl (mkModuleName "Prelude")+ prelude = noLocA $ simpleImportDecl (mkModuleName "Prelude") -- Predicate to test for a 'Prelude' import declaration. isPrelude :: LImportDecl GhcPs -> Bool@@ -52,7 +58,7 @@ -- thing. This is the case if the names are equal and (1) denote a -- builtin type or data constructor or (2) the intersection of the -- candidate modules where the two names arise is non-empty.-scopeMatch :: (Scope, Located RdrName) -> (Scope, Located RdrName) -> Bool+scopeMatch :: (Scope, LocatedN RdrName) -> (Scope, LocatedN RdrName) -> Bool scopeMatch (a, x) (b, y) | isSpecial x && isSpecial y = rdrNameStr x == rdrNameStr y | isSpecial x || isSpecial y = False@@ -62,60 +68,75 @@ -- Given a name in a scope, and a new scope, create a name for the new -- scope that will refer to the same thing. If the resulting name is -- ambiguous, pick a plausible candidate.-scopeMove :: (Scope, Located RdrName) -> Scope -> Located RdrName+scopeMove :: (Scope, LocatedN RdrName) -> Scope -> LocatedN RdrName scopeMove (a, x@(fromQual -> Just name)) (Scope b) = case imps of- [] -> headDef x real- imp:_ | all (\x -> ideclQualified x /= NotQualified) imps -> noLoc $ mkRdrQual (unLoc . fromMaybe (ideclName imp) $ firstJust ideclAs imps) name+ [] | -- If `possModules a x` includes Prelude, but `b` does not contain any module that may import `x`,+ -- then unqualify `x` and assume that it is from Prelude (#1298).+ any (\(L _ x) -> (moduleNameString . fst <$> isQual_maybe x) == Just "Prelude") real -> unqual x+ | otherwise -> headDef x real+ imp:_ | all (\x -> ideclQualified x /= NotQualified) imps -> noLocA $ mkRdrQual (unLoc . fromMaybe (ideclName imp) $ firstJust ideclAs imps) name | otherwise -> unqual x where- real :: [Located RdrName]- real = [noLoc $ mkRdrQual m name | m <- possModules a x]+ real :: [LocatedN RdrName]+ real = [noLocA $ mkRdrQual m name | m <- possModules a x] imps :: [ImportDecl GhcPs]- imps = [unLoc i | r <- real, i <- b, possImport i r]+ imps = [unLoc i | r <- real, i <- b, possImport i r /= NotImported] scopeMove (_, x) _ = x -- Calculate which modules a name could possibly lie in. If 'x' is -- qualified but no imported element matches it, assume the user just -- lacks an import.-possModules :: Scope -> Located RdrName -> [ModuleName]-possModules (Scope is) x = f x+-- 'prelude' is added to the result, unless we are certain which module a name is from (#1298).+possModules :: Scope -> LocatedN RdrName -> [ModuleName]+possModules (Scope is) x =+ [prelude | prelude `notElem` map fst res, not (any snd res)] ++ fmap fst res where- res :: [ModuleName]- res = [unLoc $ ideclName $ unLoc i | i <- is, possImport i x]+ -- The 'Bool' signals whether we are certain that 'x' is imported from the module.+ res0, res :: [(ModuleName, Bool)]+ res0 = [ (unLoc $ ideclName $ unLoc i, isImported == Imported)+ | i <- is, let isImported = possImport i x, isImported /= NotImported ] - f :: Located RdrName -> [ModuleName]- f n | isSpecial n = [mkModuleName ""]- f (L _ (Qual mod _)) = [mod | null res] ++ res- f _ = res+ res | isSpecial x = [(mkModuleName "", True)]+ | L _ (Qual mod _) <- x = [(mod, True) | null res0] ++ res0+ | otherwise = res0 + prelude = mkModuleName "Prelude"++data IsImported = Imported | PossiblyImported | NotImported deriving (Eq)+ -- Determine if 'x' could possibly lie in the module named by the -- import declaration 'i'.-possImport :: LImportDecl GhcPs -> Located RdrName -> Bool-possImport i n | isSpecial n = False+possImport :: LImportDecl GhcPs -> LocatedN RdrName -> IsImported+possImport i n | isSpecial n = NotImported possImport (L _ i) (L _ (Qual mod x)) =- mod `elem` ms && possImport (noLoc i{ideclQualified=NotQualified}) (noLoc $ mkRdrUnqual x)+ if mod `elem` ms && NotImported /= possImport (noLocA i{ideclQualified=NotQualified}) (noLocA $ mkRdrUnqual x)+ then Imported+ else NotImported where ms = map unLoc $ ideclName i : maybeToList (ideclAs i)-possImport (L _ i) (L _ (Unqual x)) = ideclQualified i == NotQualified && maybe True f (ideclHiding i)+possImport (L _ i) (L _ (Unqual x)) =+ if ideclQualified i == NotQualified+ then maybe PossiblyImported (f . first (== EverythingBut)) (ideclImportList i)+ else NotImported where- f :: (Bool, Located [LIE GhcPs]) -> Bool- f (hide, L _ xs) =- if hide then- Just True `notElem` ms- else- Nothing `elem` ms || Just True `elem` ms+ f :: (Bool, LocatedLI [LocatedA (IE GhcPs)]) -> IsImported+ f (hide, L _ xs)+ | hide = if Just True `elem` ms then NotImported else PossiblyImported+ | Just True `elem` ms = Imported+ | Nothing `elem` ms = PossiblyImported+ | otherwise = NotImported where ms = map g xs tag :: String tag = occNameString x g :: LIE GhcPs -> Maybe Bool -- Does this import cover the name 'x'?- g (L _ (IEVar _ y)) = Just $ tag == unwrapName y- g (L _ (IEThingAbs _ y)) = Just $ tag == unwrapName y- g (L _ (IEThingAll _ y)) = if tag == unwrapName y then Just True else Nothing- g (L _ (IEThingWith _ y _wildcard ys _fields)) = Just $ tag `elem` unwrapName y : map unwrapName ys+ g (L _ (IEVar _ y _)) = Just $ tag == unwrapName y+ g (L _ (IEThingAbs _ y _)) = Just $ tag == unwrapName y+ g (L _ (IEThingAll _ y _)) = if tag == unwrapName y then Just True else Nothing+ g (L _ (IEThingWith _ y _ ys _)) = Just $ tag `elem` unwrapName y : map unwrapName ys g _ = Just False - unwrapName :: LIEWrappedName RdrName -> String+ unwrapName :: LIEWrappedName GhcPs -> String unwrapName x = occNameString (rdrNameOcc $ ieWrappedName (unLoc x))-possImport _ _ = False+possImport _ _ = NotImported
src/GHC/Util/SrcLoc.hs view
@@ -1,21 +1,35 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Util.SrcLoc (- stripLocs+ getAncLoc+ , stripLocs , SrcSpanD(..) ) where +import GHC.Parser.Annotation import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Data.FastString+import GHC.Data.Strict qualified import Data.Default import Data.Data import Data.Generics.Uniplate.DataOnly +-- Get the 'SrcSpan' out of a value located by an 'NoCommentsLocation'+-- (e.g. comments).+getAncLoc :: GenLocated NoCommentsLocation a -> SrcSpan+getAncLoc o = RealSrcSpan (GHC.Parser.Annotation.epaLocationRealSrcSpan (GHC.Types.SrcLoc.getLoc o)) GHC.Data.Strict.Nothing+ -- 'stripLocs x' is 'x' with all contained source locs replaced by -- 'noSrcSpan'. stripLocs :: Data from => from -> from-stripLocs = transformBi (const noSrcSpan)+stripLocs =+ transformBi (const dummySpan) . transformBi (const noSrcSpan)+ where+ dummyLoc = mkRealSrcLoc (fsLit "dummy") 1 1+ dummySpan = mkRealSrcSpan dummyLoc dummyLoc -- TODO (2020-10-03, SF): Maybe move the following definitions down to -- ghc-lib-parser at some point.@@ -25,6 +39,12 @@ deriving (Outputable, Eq) instance Default SrcSpanD where def = SrcSpanD noSrcSpan +newtype FastStringD = FastStringD FastString+ deriving Eq+compareFastStrings (FastStringD f) (FastStringD g) =+ lexicalCompareFS f g+instance Ord FastStringD where compare = compareFastStrings+ -- SrcSpan no longer provides 'Ord' so we are forced to roll our own. -- -- Note: This implementation chooses that any span compares 'EQ to an@@ -38,7 +58,7 @@ _ -> EQ -- error "'Duplicate.hs' invariant error: can't compare unhelpful spans" _ -> EQ -- error "'Duplicate.hs' invariant error: can't compare unhelpful spans" compareRealSrcSpans a b =- let (a1, a2, a3, a4, a5) = (srcSpanFile a, srcSpanStartLine a, srcSpanStartCol a, srcSpanEndLine a, srcSpanEndCol a)- (b1, b2, b3, b4, b5) = (srcSpanFile b, srcSpanStartLine b, srcSpanStartCol b, srcSpanEndLine b, srcSpanEndCol b)+ let (a1, a2, a3, a4, a5) = (LexicalFastString (srcSpanFile a), srcSpanStartLine a, srcSpanStartCol a, srcSpanEndLine a, srcSpanEndCol a)+ (b1, b2, b3, b4, b5) = (LexicalFastString (srcSpanFile b), srcSpanStartLine b, srcSpanStartCol b, srcSpanEndLine b, srcSpanEndCol b) in compare (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5) instance Ord SrcSpanD where compare = compareSrcSpans
src/GHC/Util/Unify.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables, TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}+{-# LANGUAGE DataKinds #-} module GHC.Util.Unify(- Subst, fromSubst,+ Subst(..), fromSubst, validSubst, removeParens, substitute, unifyExp ) where@@ -61,11 +62,15 @@ removeParens noParens (Subst xs) = Subst $ map (\(x, y) -> if x `elem` noParens then (x, fromParen y) else (x, y)) xs --- Peform a substition.--- Returns (suggested replacement, refactor template), both with brackets added--- as needed.--- Example: (traverse foo (bar baz), traverse f (x))-substitute :: Subst (LHsExpr GhcPs) -> LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs)+-- Perform a substitution.+-- Returns (suggested replacement, (refactor template, no bracket vars)). It adds/removes brackets+-- for both the suggested replacement and the refactor template appropriately. The "no bracket vars"+-- is a list of substitution variables which, when expanded, should have the brackets stripped.+--+-- Examples:+-- (traverse foo (bar baz), (traverse f (x), []))+-- (zipWith foo bar baz, (f a b, [f]))+substitute :: Subst (LHsExpr GhcPs) -> LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String])) substitute (Subst bind) = transformBracketOld exp . transformBi pat . transformBi typ where exp :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)@@ -98,7 +103,7 @@ --------------------------------------------------------------------- -- UNIFICATION -type NameMatch = Located RdrName -> Located RdrName -> Bool+type NameMatch = LocatedN RdrName -> LocatedN RdrName -> Bool -- | Unification, obeys the property that if @unify a b = s@, then -- @substitute s a = b@.@@ -108,11 +113,46 @@ | Just (x, y) <- cast (x, y) = unifyPat' nm x y | Just (x, y) <- cast (x, y) = unifyType' nm x y | Just (x, y) <- cast (x, y) = if (x :: FastString) == y then Just mempty else Nothing- | Just (x :: SrcSpan) <- cast x = Just mempty++ -- We need some type magic to reduce this.+ | Just (x :: EpAnn EpaLocation) <- cast x = Just mempty+ | Just (x :: EpAnn AnnContext) <- cast x = Just mempty+ | Just (x :: EpAnn AnnExplicitSum) <- cast x = Just mempty+ | Just (x :: EpAnn AnnFieldLabel) <- cast x = Just mempty+ | Just (x :: EpAnn (AnnList [EpToken ","])) <- cast x = Just mempty+ | Just (x :: EpAnn AnnListItem) <- cast x = Just mempty+ | Just (x :: EpAnn AnnParen) <- cast x = Just mempty+ | Just (x :: EpAnn AnnPragma) <- cast x = Just mempty+ | Just (x :: EpAnn AnnProjection) <- cast x = Just mempty+ | Just (x :: EpAnn AnnsIf) <- cast x = Just mempty+ | Just (x :: EpAnn AnnSig) <- cast x = Just mempty+ | Just (x :: EpAnn AnnsModule) <- cast x = Just mempty+ | Just (x :: EpAnn EpAnnHsCase) <- cast x = Just mempty+ | Just (x :: EpAnn EpAnnImportDecl) <- cast x = Just mempty+ | Just (x :: EpAnn EpAnnSumPat) <- cast x = Just mempty+ | Just (x :: EpAnn EpAnnUnboundVar) <- cast x = Just mempty+ | Just (x :: EpAnn GrhsAnn) <- cast x = Just mempty+ | Just (x :: EpAnn HsRuleAnn) <- cast x = Just mempty+ | Just (x :: EpAnn NameAnn) <- cast x = Just mempty+ | Just (x :: EpAnn NoEpAnns) <- cast x = Just mempty+ | Just (x :: EpToken "let") <- cast x = Just mempty+ | Just (x :: EpToken "in") <- cast x = Just mempty+ | Just (x :: EpToken "@") <- cast x = Just mempty+ | Just (x :: EpToken "(") <- cast x = Just mempty+ | Just (x :: EpToken ")") <- cast x = Just mempty+ | Just (x :: EpToken "type") <- cast x = Just mempty+ | Just (x :: EpToken "%") <- cast x = Just mempty+ | Just (x :: EpToken "%1") <- cast x = Just mempty+ | Just (x :: EpToken "⊸") <- cast x = Just mempty+ | Just (x :: EpUniToken "->" "→") <- cast x = Just mempty+ | Just (x :: TokenLocation) <- cast y = Just mempty+ | Just (y :: SrcSpan) <- cast y = Just mempty+ | otherwise = unifyDef' nm x y unifyDef' :: Data a => NameMatch -> a -> a -> Maybe (Subst (LHsExpr GhcPs))-unifyDef' nm x y = fmap mconcat . sequence =<< gzip (unify' nm False) x y+unifyDef' nm x y =+ fmap mconcat . sequence =<< gzip (unify' nm False) x y unifyComposed' :: NameMatch -> LHsExpr GhcPs@@ -122,7 +162,7 @@ ((, Just y11) <$> unifyExp' nm False x1 y12) <|> case y12 of (L _ (OpApp _ y121 dot' y122)) | isDot dot' ->- unifyComposed' nm x1 (noLoc (OpApp noExtField y11 dot y121)) dot' y122+ unifyComposed' nm x1 (noLocA (OpApp noExtField y11 dot y121)) dot' y122 _ -> Nothing -- unifyExp handles the cases where both x and y are HsApp, or y is OpApp. Otherwise,@@ -156,7 +196,7 @@ -- Attempt #1: rewrite '(fun1 . fun2) arg' as 'fun1 (fun2 arg)', and unify it with 'x'. -- The guard ensures that you don't get duplicate matches because the matching engine -- auto-generates hints in dot-form.- (, Nothing) <$> unifyExp' nm root x (noLoc (HsApp noExtField y11 (noLoc (HsApp noExtField y12 y2))))+ (, Nothing) <$> unifyExp' nm root x (noLocA (HsApp noExtField y11 (noLocA (HsApp noExtField y12 y2)))) else do -- Attempt #2: rewrite '(fun1 . fun2 ... funn) arg' as 'fun1 $ (fun2 ... funn) arg', -- 'fun1 . fun2 $ (fun3 ... funn) arg', 'fun1 . fun2 . fun3 $ (fun4 ... funn) arg',@@ -171,9 +211,9 @@ unifyExp nm root x (L _ (OpApp _ lhs2 op2@(L _ (HsVar _ op2')) rhs2)) | (L _ (OpApp _ lhs1 op1@(L _ (HsVar _ op1')) rhs1)) <- x = guard (nm op1' op2') >> (, Nothing) <$> liftA2 (<>) (unifyExp' nm False lhs1 lhs2) (unifyExp' nm False rhs1 rhs2)- | isDol op2 = unifyExp nm root x $ noLoc (HsApp noExtField lhs2 rhs2)- | isAmp op2 = unifyExp nm root x $ noLoc (HsApp noExtField rhs2 lhs2)- | otherwise = unifyExp nm root x $ noLoc (HsApp noExtField (noLoc (HsApp noExtField op2 (addPar lhs2))) (addPar rhs2))+ | isDol op2 = unifyExp nm root x $ noLocA (HsApp noExtField lhs2 rhs2)+ | isAmp op2 = unifyExp nm root x $ noLocA (HsApp noExtField rhs2 lhs2)+ | otherwise = unifyExp nm root x $ noLocA (HsApp noExtField (noLocA (HsApp noExtField op2 (addPar lhs2))) (addPar rhs2)) where -- add parens around when desugaring the expression, if necessary addPar :: LHsExpr GhcPs -> LHsExpr GhcPs@@ -183,6 +223,7 @@ isAmp :: LHsExpr GhcPs -> Bool isAmp (L _ (HsVar _ x)) = rdrNameStr x == "&"+isAmp _ = False -- | If we "throw away" the extra than we have no where to put it, and the substitution is wrong noExtra :: Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)) -> Maybe (Subst (LHsExpr GhcPs))@@ -194,7 +235,7 @@ -- dot at the root, since otherwise you get two matches because of -- 'readRule' (Bug #570). unifyExp' :: NameMatch -> Bool -> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst (LHsExpr GhcPs))--- Don't subsitute for type apps, since no one writes rules imagining+-- Don't substitute for type apps, since no one writes rules imagining -- they exist. unifyExp' nm root (L _ (HsVar _ (rdrNameStr -> v))) y | isUnifyVar v, not $ isTypeApp y = Just $ Subst [(v, y)] unifyExp' nm root (L _ (HsVar _ x)) (L _ (HsVar _ y)) | nm x y = Just mempty@@ -224,8 +265,8 @@ unifyExp' nm root x y@(L _ (OpApp _ lhs2 op2@(L _ (HsVar _ op2')) rhs2)) = noExtra $ unifyExp nm root x y -unifyExp' nm root (L _ (HsBracket _ (VarBr _ b0 (occNameStr -> v1))))- (L _ (HsBracket _ (VarBr _ b1 (occNameStr -> v2))))+unifyExp' nm root (L _ (HsUntypedBracket _ (VarBr _ b0 (occNameStr . unLoc -> v1))))+ (L _ (HsUntypedBracket _ (VarBr _ b1 (occNameStr . unLoc -> v2)))) | b0 == b1 && isUnifyVar v1 = Just (Subst [(v1, strToVar v2)]) unifyExp' nm root x y | isOther x, isOther y = unifyDef' nm x y@@ -254,7 +295,7 @@ unifyType' :: NameMatch -> LHsType GhcPs -> LHsType GhcPs -> Maybe (Subst (LHsExpr GhcPs)) unifyType' nm (L loc (HsTyVar _ _ x)) y = let wc = HsWC noExtField y :: LHsWcType (NoGhcTc GhcPs)- unused = strToVar "__unused__" :: LHsExpr GhcPs- appType = L loc (HsAppType noExtField unused wc) :: LHsExpr GhcPs+ unused = strToVar "__unused__"+ appType = L loc (HsAppType noAnn unused wc) in Just $ Subst [(rdrNameStr x, appType)] unifyType' nm x y = unifyDef' nm x y
src/GHC/Util/View.hs view
@@ -14,52 +14,52 @@ import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import GHC.Util.Brackets -fromParen :: LHsExpr GhcPs -> LHsExpr GhcPs+fromParen :: LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs) fromParen x = maybe x fromParen $ remParen x -fromPParen :: LPat GhcPs -> LPat GhcPs+fromPParen :: LocatedA (Pat GhcPs) -> LocatedA (Pat GhcPs) fromPParen (L _ (ParPat _ x)) = fromPParen x fromPParen x = x class View a b where view :: a -> b -data RdrName_ = NoRdrName_ | RdrName_ (Located RdrName)+data RdrName_ = NoRdrName_ | RdrName_ (LocatedN RdrName) data Var_ = NoVar_ | Var_ String deriving Eq data PVar_ = NoPVar_ | PVar_ String-data PApp_ = NoPApp_ | PApp_ String [LPat GhcPs]-data App2 = NoApp2 | App2 (LHsExpr GhcPs) (LHsExpr GhcPs) (LHsExpr GhcPs)-data LamConst1 = NoLamConst1 | LamConst1 (LHsExpr GhcPs)+data PApp_ = NoPApp_ | PApp_ String [LocatedA (Pat GhcPs)]+data App2 = NoApp2 | App2 (LocatedA (HsExpr GhcPs)) (LocatedA (HsExpr GhcPs)) (LocatedA (HsExpr GhcPs))+data LamConst1 = NoLamConst1 | LamConst1 (LocatedA (HsExpr GhcPs)) -instance View (LHsExpr GhcPs) LamConst1 where- view (fromParen -> (L _ (HsLam _ (MG _ (L _ [L _ (Match _ LambdaExpr [L _ WildPat {}]- (GRHSs _ [L _ (GRHS _ [] x)] (L _ (EmptyLocalBinds _))))]) FromSource)))) = LamConst1 x+instance View (LocatedA (HsExpr GhcPs)) LamConst1 where+ view (fromParen -> (L _ (HsLam _ _ (MG FromSource (L _ [L _ (Match _ (LamAlt _) (L _ [L _ WildPat {}])+ (GRHSs _ [L _ (GRHS _ [] x)] ((EmptyLocalBinds _))))]))))) = LamConst1 x view _ = NoLamConst1 -instance View (LHsExpr GhcPs) RdrName_ where+instance View (LocatedA (HsExpr GhcPs)) RdrName_ where view (fromParen -> (L _ (HsVar _ name))) = RdrName_ name view _ = NoRdrName_ -instance View (LHsExpr GhcPs) Var_ where+instance View (LocatedA (HsExpr GhcPs)) Var_ where view (view -> RdrName_ name) = Var_ (rdrNameStr name) view _ = NoVar_ -instance View (LHsExpr GhcPs) App2 where+instance View (LocatedA (HsExpr GhcPs)) App2 where view (fromParen -> L _ (OpApp _ lhs op rhs)) = App2 op lhs rhs view (fromParen -> L _ (HsApp _ (L _ (HsApp _ f x)) y)) = App2 f x y view _ = NoApp2 -instance View (Located (Pat GhcPs)) PVar_ where+instance View (LocatedA (Pat GhcPs)) PVar_ where view (fromPParen -> L _ (VarPat _ (L _ x))) = PVar_ $ occNameStr x view _ = NoPVar_ -instance View (Located (Pat GhcPs)) PApp_ where- view (fromPParen -> L _ (ConPat _ (L _ x) (PrefixCon args))) =+instance View (LocatedA (Pat GhcPs)) PApp_ where+ view (fromPParen -> L _ (ConPat _ (L _ x) (PrefixCon _ args))) = PApp_ (occNameStr x) args view (fromPParen -> L _ (ConPat _ (L _ x) (InfixCon lhs rhs))) = PApp_ (occNameStr x) [lhs, rhs] view _ = NoPApp_ -- A lambda with no guards and no where clauses-pattern SimpleLambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs-pattern SimpleLambda vs body <- L _ (HsLam _ (MG _ (L _ [L _ (Match _ _ vs (GRHSs _ [L _ (GRHS _ [] body)] (L _ (EmptyLocalBinds _))))]) _))+pattern SimpleLambda :: [LocatedA (Pat GhcPs)] -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)+pattern SimpleLambda vs body <- L _ (HsLam _ LamSingle (MG _ (L _ [L _ (Match _ _ (L _ vs) (GRHSs _ [L _ (GRHS _ [] body)] ((EmptyLocalBinds _))))])))
src/HLint.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-}@@ -17,6 +18,7 @@ import System.IO.Extra import System.Time.Extra import Data.Tuple.Extra+import Data.Bifunctor (bimap) import Prelude import CmdLine@@ -36,6 +38,7 @@ import CC import EmbedData +import SARIF qualified -- | This function takes a list of command line arguments, and returns the given hints. -- To see a list of arguments type @hlint --help@ at the console.@@ -81,19 +84,37 @@ | 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 mapM_ (putStrLn . fst <=< computeSettings (cmdParseFlags cmd)) hints >> pure []@@ -149,12 +170,13 @@ runHints args settings cmd@CmdMain{..} = withNumCapabilities cmdThreads $ do let outStrLn = whenNormal . putStrLn- ideas <- getIdeas cmd settings- ideas <- pure $ if cmdShowAll then ideas else filter (\i -> ideaSeverity i /= Ignore) ideas+ ideas <- filterIdeas <$> getIdeas cmd settings if cmdJson then putStrLn $ showIdeasJson ideas else if cmdCC then mapM_ (printIssue . fromIdea) ideas+ else if cmdSARIF then+ SARIF.printIdeas ideas else if cmdSerialise then do hSetBuffering stdout NoBuffering print $ map (show &&& ideaRefactoring) ideas@@ -166,6 +188,12 @@ mapM_ (outStrLn . showItem) ideas handleReporting ideas cmd pure ideas+ where+ filteredSeverities+ | cmdShowAll = []+ | cmdIgnoreSuggestions = [Ignore, Suggestion]+ | otherwise = [Ignore]+ filterIdeas = filter (\i -> ideaSeverity i `notElem` filteredSeverities) getIdeas :: Cmd -> [Setting] -> IO [Idea] getIdeas cmd@CmdMain{..} settings = do@@ -201,8 +229,14 @@ outStrLn $ "Writing report to " ++ x ++ " ..." writeReport cmdDataDir x showideas unless cmdNoSummary $ do- let n = length showideas- outStrLn $ if n == 0 then "No hints" else show n ++ " hint" ++ ['s' | n/=1]+ let (nbErrors, nbHints) = bimap length length $ partition (\idea -> ideaSeverity idea == Error) showideas+ when (nbErrors > 0) (outStrLn $ formatOutput nbErrors "error")+ unless (nbErrors > 0 && nbHints == 0) (outStrLn $ formatOutput nbHints "hint")++ where+ formatOutput :: Int -> String -> String+ formatOutput number name =+ if number == 0 then "No " ++ name ++ "s" else show number ++ " " ++ name ++ ['s' | number/=1] evaluateList :: [a] -> IO [a] evaluateList xs = do
src/Hint/All.hs view
@@ -21,6 +21,7 @@ import Hint.Bracket import Hint.Fixities import Hint.Naming+import Hint.Negation import Hint.Pattern import Hint.Import import Hint.Export@@ -32,14 +33,15 @@ import Hint.Unsafe import Hint.NewType import Hint.Smell+import Hint.NumLiteral -- | A list of the builtin hints wired into HLint. -- This list is likely to grow over time. data HintBuiltin =- HintList | HintListRec | HintMonad | HintLambda | HintFixities |+ HintList | HintListRec | HintMonad | HintLambda | HintFixities | HintNegation | HintBracket | HintNaming | HintPattern | HintImport | HintExport | HintPragma | HintExtensions | HintUnsafe | HintDuplicate | HintRestrict |- HintComment | HintNewType | HintSmell+ HintComment | HintNewType | HintSmell | HintNumLiteral deriving (Show,Eq,Ord,Bounded,Enum) -- See https://github.com/ndmitchell/hlint/issues/1150 - Duplicate is too slow@@ -48,7 +50,6 @@ builtin :: HintBuiltin -> Hint builtin x = case x of- -- Ghc. HintLambda -> decl lambdaHint HintImport -> modu importHint HintExport -> modu exportHint@@ -63,10 +64,12 @@ HintNaming -> decl namingHint HintBracket -> decl bracketHint HintFixities -> mempty{hintDecl=fixitiesHint}+ HintNegation -> decl negationParensHint HintSmell -> mempty{hintDecl=smellHint,hintModule=smellModuleHint} HintPattern -> decl patternHint HintMonad -> decl monadHint HintExtensions -> modu extensionsHint+ HintNumLiteral -> decl numLiteralHint where wrap = timed "Hint" (drop 4 $ show x) . forceList decl f = mempty{hintDecl=const $ \a b c -> wrap $ f a b c}
src/Hint/Bracket.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns, ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}@@ -45,6 +46,13 @@ issue1179 = do(this is a test) -- do this is a test issue1212 = $(Git.hash) +-- no record dot syntax+referenceDesignator = ReferenceDesignator (p.placementReferenceDesignator)++-- record dot syntax+{-# LANGUAGE OverloadedRecordDot #-} \+referenceDesignator = ReferenceDesignator (p.placementReferenceDesignator) -- p.placementReferenceDesignator @NoRefactor: refactor requires GHC >= 9.2.1+ -- type bracket reduction foo :: (Int -> Int) -> Int foo :: (Maybe Int) -> a -- @Suggestion Maybe Int -> a@@ -55,7 +63,6 @@ foo (x:xs) = 1 foo (True) = 1 -- @Warning True foo ((True)) = 1 -- @Warning True-foo (A{}) = True -- A{} f x = case x of (Nothing) -> 1; _ -> 2 -- Nothing -- dollar reduction tests@@ -94,16 +101,35 @@ special = foo $ Rec{x=1} special = foo (f{x=1}) loadCradleOnlyonce = skipManyTill anyMessage (message @PublishDiagnosticsNotification)+-- These used to require a bracket+$(pure [])+$(x)+-- People aren't a fan of the record constructors being secretly atomic+function (Ctor (Rec { field })) = Ctor (Rec {field = 1}) -- type splices are a bit special no = f @($x)++-- template haskell is harder+issue1292 = [e| handleForeignCatch $ \ $(varP pylonExPtrVarName) -> $(quoteExp C.block modifiedStr) |]++-- no warnings for single-argument constraint contexts+foo :: (A) => ()+bar :: (A a) => ()+foo' :: ((A) => ()) -> ()+bar' :: ((A a) => ()) -> ()+data Dict c where Dict :: (c) => Dict c+data Dict' c a where Dict' :: (c a) => Dict' c a++-- issue1501: Redundant bracket hint resulted in a parse error+x = f $ \(Proxy @a) -> True </TEST> -} module Hint.Bracket(bracketHint) where -import Hint.Type(DeclHint,Idea(..),rawIdea,warn,suggest,Severity(..),toRefactSrcSpan,toSS)+import Hint.Type(DeclHint,Idea(..),rawIdea,warn,suggest,Severity(..),toRefactSrcSpan,toSSA) import Data.Data import Data.List.Extra import Data.Generics.Uniplate.DataOnly@@ -115,54 +141,72 @@ import GHC.Util import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import Language.Haskell.GhclibParserEx.GHC.Hs.Pat bracketHint :: DeclHint bracketHint _ _ x =- concatMap (\x -> bracket prettyExpr isPartialAtom True x ++ dollar x) (childrenBi (descendBi annotations x) :: [LHsExpr GhcPs]) ++- concatMap (bracket unsafePrettyPrint (\_ _ -> False) False) (childrenBi x :: [LHsType GhcPs]) +++ concatMap (\x -> bracket prettyExpr isPartialAtom True x ++ dollar x) (childrenBi (descendBi splices $ descendBi annotations x) :: [LHsExpr GhcPs]) +++ concatMap (bracket unsafePrettyPrint (\_ _ -> False) False) (childrenBi (preprocess x) :: [LHsType GhcPs]) ++ concatMap (bracket unsafePrettyPrint (\_ _ -> False) False) (childrenBi x :: [LPat GhcPs]) ++ concatMap fieldDecl (childrenBi x) where+ preprocess = transformBi removeSingleAtomConstrCtxs+ where+ removeSingleAtomConstrCtxs :: LHsContext GhcPs -> LHsContext GhcPs+ removeSingleAtomConstrCtxs = fmap $ \case+ [ty] | isAtom ty -> []+ tys -> tys+ -- Brackets the roots of annotations are fine, so we strip them. annotations :: AnnDecl GhcPs -> AnnDecl GhcPs annotations= descendBi $ \x -> case (x :: LHsExpr GhcPs) of L _ (HsPar _ x) -> x x -> x + -- Brackets at the root of splices used to be required, but now they aren't+ splices :: HsDecl GhcPs -> HsDecl GhcPs+ splices (SpliceD a x) = SpliceD a $ flip descendBi x $ \x -> case (x :: LHsExpr GhcPs) of+ L _ (HsPar _ x) -> x+ x -> x+ splices x = x+ -- If we find ourselves in the context of a section and we want to--- issue a warning that a child therein has unneccessary brackets,+-- issue a warning that a child therein has unnecessary brackets, -- we'd rather report 'Found : (`Foo` (Bar Baz))' rather than 'Found : -- `Foo` (Bar Baz)'. If left to 'unsafePrettyPrint' we'd get the -- latter (in contrast to the HSE pretty printer). This patches things -- up. prettyExpr :: LHsExpr GhcPs -> String-prettyExpr s@(L _ SectionL{}) = unsafePrettyPrint (noLoc (HsPar noExtField s) :: LHsExpr GhcPs)-prettyExpr s@(L _ SectionR{}) = unsafePrettyPrint (noLoc (HsPar noExtField s) :: LHsExpr GhcPs)+prettyExpr s@(L _ SectionL{}) = unsafePrettyPrint (nlHsPar s :: LHsExpr GhcPs)+prettyExpr s@(L _ SectionR{}) = unsafePrettyPrint (nlHsPar s :: LHsExpr GhcPs) prettyExpr x = unsafePrettyPrint x -- 'Just _' if at least one set of parens were removed. 'Nothing' if -- zero parens were removed.-remParens' :: Brackets (Located a) => Located a -> Maybe (Located a)+remParens' :: Brackets (LocatedA a) => LocatedA a -> Maybe (LocatedA a) remParens' = fmap go . remParen where go e = maybe e go (remParen e) +-- note(sf, 2022-06-02): i've completely bluffed my way through this.+-- see+-- https://gitlab.haskell.org/ghc/ghc/-/commit/7975202ba9010c581918413808ee06fbab9ac85f+-- for where splice expressions were refactored. isPartialAtom :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool -- Might be '$x', which was really '$ x', but TH enabled misparsed it.-isPartialAtom _ (L _ (HsSpliceE _ (HsTypedSplice _ DollarSplice _ _) )) = True-isPartialAtom _ (L _ (HsSpliceE _ (HsUntypedSplice _ DollarSplice _ _) )) = True+isPartialAtom _ (L _ (HsUntypedSplice _ HsUntypedSpliceExpr{})) = True -- Might be '$(x)' where the brackets are required in GHC 8.10 and below-isPartialAtom (Just (L _ HsSpliceE{})) _ = True+isPartialAtom (Just (L _ HsUntypedSplice{})) _ = True isPartialAtom _ x = isRecConstr x || isRecUpdate x -bracket :: forall a . (Data a, Outputable a, Brackets (Located a)) => (Located a -> String) -> (Maybe (Located a) -> Located a -> Bool) -> Bool -> Located a -> [Idea]+bracket :: forall a . (Data a, Outputable a, Brackets (LocatedA a)) => (LocatedA a -> String) -> (Maybe (LocatedA a) -> LocatedA a -> Bool) -> Bool -> LocatedA a -> [Idea] bracket pretty isPartialAtom root = f Nothing where msg = "Redundant bracket" -- 'f' is a (generic) function over types in 'Brackets -- (expressions, patterns and types). Arguments are, 'f (Maybe -- (index, parent, gen)) child'.- f :: (Data a, Outputable a, Brackets (Located a)) => Maybe (Int, Located a , Located a -> Located a) -> Located a -> [Idea]+ f :: (Data a, Outputable a, Brackets (LocatedA a)) => Maybe (Int, LocatedA a , LocatedA a -> LocatedA a) -> LocatedA a -> [Idea] -- No context. Removing parentheses from 'x' succeeds? f Nothing o@(remParens' -> Just x) -- If at the root, or 'x' is an atom, 'x' parens are redundant.@@ -178,43 +222,43 @@ -- In some context, removing parentheses from 'x' succeeds. Does -- 'x' actually need bracketing in this context? f (Just (i, o, gen)) v@(remParens' -> Just x)- | not $ needBracket i o x, not $ isPartialAtom (Just o) x =- rawIdea Suggestion msg (getLoc v) (pretty o) (Just (pretty (gen x))) [] [r] : g x+ | not $ needBracket i o x+ , not $ isPartialAtom (Just o) x+ , not $ any isSplicePat $ universeBi o -- over-appoximate ,see #1292+ = rawIdea Suggestion msg (getLocA v) (pretty o) (Just (pretty (gen x))) [] [r] : g x where typ = findType v- r = Replace typ (toSS v) [("x", toSS x)] "x"+ r = Replace typ (toSSA v) [("x", toSSA x)] "x" -- Regardless of the context, there are no parentheses to remove -- from 'x'. f _ x = g x - g :: (Data a, Outputable a, Brackets (Located a)) => Located a -> [Idea]+ g :: (Data a, Outputable a, Brackets (LocatedA a)) => LocatedA a -> [Idea] -- Enumerate over all the immediate children of 'o' looking for -- redundant parentheses in each. g o = concat [f (Just (i, o, gen)) x | (i, (x, gen)) <- zipFrom 0 $ holes o] -bracketWarning :: (Outputable a, Outputable b, Brackets (Located b)) => String -> Located a -> Located b -> Idea bracketWarning msg o x =- suggest msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"]+ suggest msg (reLoc o) (reLoc x) [Replace (findType x) (toSSA o) [("x", toSSA x)] "x"] -bracketError :: (Outputable a, Outputable b, Brackets (Located b)) => String -> Located a -> Located b -> Idea+bracketError :: (Outputable a, Outputable b, Brackets (LocatedA b)) => String -> LocatedA a -> LocatedA b -> Idea bracketError msg o x =- warn msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"]+ warn msg (reLoc o) (reLoc x) [Replace (findType x) (toSSA o) [("x", toSSA x)] "x"] fieldDecl :: LConDeclField GhcPs -> [Idea] fieldDecl o@(L loc f@ConDeclField{cd_fld_type=v@(L l (HsParTy _ c))}) = let r = L loc (f{cd_fld_type=c}) :: LConDeclField GhcPs in- [rawIdea Suggestion "Redundant bracket" l+ [rawIdea Suggestion "Redundant bracket" (locA l) (showSDocUnsafe $ ppr_fld o) -- Note this custom printer! (Just (showSDocUnsafe $ ppr_fld r)) []- [Replace Type (toSS v) [("x", toSS c)] "x"]]+ [Replace Type (toSSA v) [("x", toSSA c)] "x"]] where -- If we call 'unsafePrettyPrint' on a field decl, we won't like -- the output (e.g. "[foo, bar] :: T"). Here we use a custom- -- printer to work around (snarfed from- -- https://hackage.haskell.org/package/ghc-lib-parser-8.8.1/docs/src/HsTypes.html#pprConDeclFields).+ -- printer to work around (snarfed from Hs.Types.pprConDeclFields) ppr_fld (L _ ConDeclField { cd_fld_names = ns, cd_fld_type = ty, cd_fld_doc = doc })- = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc+ = pprMaybeWithDoc doc (ppr_names ns <+> dcolon <+> ppr ty) ppr_fld (L _ (XConDeclField x)) = ppr x ppr_names [n] = ppr n@@ -226,31 +270,31 @@ dollar :: LHsExpr GhcPs -> [Idea] dollar = concatMap f . universe where- f x = [ (suggest "Redundant $" x y [r]){ideaSpan = getLoc d} | L _ (OpApp _ a d b) <- [x], isDol d- , let y = noLoc (HsApp noExtField a b) :: LHsExpr GhcPs+ f x = [ (suggest "Redundant $" (reLoc x) (reLoc y) [r]){ideaSpan = locA (getLoc d)} | L _ (OpApp _ a d b) <- [x], isDol d+ , let y = noLocA (HsApp noExtField a b) :: LHsExpr GhcPs , not $ needBracket 0 y a , not $ needBracket 1 y b , not $ isPartialAtom (Just x) b- , let r = Replace Expr (toSS x) [("a", toSS a), ("b", toSS b)] "a b"]+ , let r = Replace Expr (toSSA x) [("a", toSSA a), ("b", toSSA b)] "a b"] ++- [ suggest "Move brackets to avoid $" x (t y) [r]+ [ suggest "Move brackets to avoid $" (reLoc x) (reLoc (t y)) [r] |(t, e@(L _ (HsPar _ (L _ (OpApp _ a1 op1 a2))))) <- splitInfix x , isDol op1 , isVar a1 || isApp a1 || isPar a1, not $ isAtom a2 , varToStr a1 /= "select" -- special case for esqueleto, see #224- , let y = noLoc $ HsApp noExtField a1 (noLoc (HsPar noExtField a2))- , let r = Replace Expr (toSS e) [("a", toSS a1), ("b", toSS a2)] "a (b)" ]+ , let y = noLocA $ HsApp noExtField a1 (nlHsPar a2)+ , let r = Replace Expr (toSSA e) [("a", toSSA a1), ("b", toSSA a2)] "a (b)" ] ++ -- Special case of (v1 . v2) <$> v3- [ (suggest "Redundant bracket" x y [r]){ideaSpan = locPar}+ [ (suggest "Redundant bracket" (reLoc x) (reLoc y) [r]){ideaSpan = locA locPar} | L _ (OpApp _ (L locPar (HsPar _ o1@(L locNoPar (OpApp _ _ (isDot -> True) _)))) o2 v3) <- [x], varToStr o2 == "<$>"- , let y = noLoc (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs- , let r = Replace Expr (toRefactSrcSpan locPar) [("a", toRefactSrcSpan locNoPar)] "a"]+ , let y = noLocA (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs+ , let r = Replace Expr (toRefactSrcSpan (locA locPar)) [("a", toRefactSrcSpan (locA locNoPar))] "a"] ++- [ suggest "Redundant section" x y [r]+ [ suggest "Redundant section" (reLoc x) (reLoc y) [r] | L _ (HsApp _ (L _ (HsPar _ (L _ (SectionL _ a b)))) c) <- [x] -- , error $ show (unsafePrettyPrint a, gshow b, unsafePrettyPrint c)- , let y = noLoc $ OpApp noExtField a b c :: LHsExpr GhcPs- , let r = Replace Expr (toSS x) [("x", toSS a), ("op", toSS b), ("y", toSS c)] "x op y"]+ , let y = noLocA $ OpApp noExtField a b c :: LHsExpr GhcPs+ , let r = Replace Expr (toSSA x) [("x", toSSA a), ("op", toSSA b), ("y", toSSA c)] "x op y"] splitInfix :: LHsExpr GhcPs -> [(LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)] splitInfix (L l (OpApp _ lhs op rhs)) =
src/Hint/Comment.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {- <TEST>@@ -21,6 +22,7 @@ import GHC.Types.SrcLoc import GHC.Parser.Annotation import GHC.Util+import GHC.Data.Strict qualified directives :: [String] directives = words $@@ -31,7 +33,7 @@ commentHint :: ModuHint commentHint _ m = concatMap chk (ghcComments m) where- chk :: Located AnnotationComment -> [Idea]+ chk :: LEpaComment -> [Idea] chk comm | isMultiline, "#" `isSuffixOf` s && not ("#" `isPrefixOf` s) = [grab "Fix pragma markup" comm $ '#':s] | isMultiline, name `elem` directives = [grab "Use pragma syntax" comm $ "# " ++ trim s ++ " #"]@@ -41,9 +43,11 @@ name = takeWhile (\x -> isAlphaNum x || x == '_') $ trimStart s chk _ = [] - grab :: String -> Located AnnotationComment -> String -> Idea+ grab :: String -> LEpaComment -> String -> Idea grab msg o@(L pos _) s2 =- let s1 = commentText o in- rawIdea Suggestion msg pos (f s1) (Just $ f s2) [] refact+ let s1 = commentText o+ loc = RealSrcSpan (epaLocationRealSrcSpan pos) GHC.Data.Strict.Nothing+ in+ rawIdea Suggestion msg loc (f s1) (Just $ f s2) [] (refact loc) where f s = if isCommentMultiline o then "{-" ++ s ++ "-}" else "--" ++ s- refact = [ModifyComment (toRefactSrcSpan pos) (f s2)]+ refact loc = [ModifyComment (toRefactSrcSpan loc) (f s2)]
src/Hint/Duplicate.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE PatternGuards, ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} @@ -30,13 +31,12 @@ import Data.Maybe import Data.Tuple.Extra import Data.List hiding (find)-import qualified Data.List.NonEmpty as NE-import qualified Data.Map as Map+import Data.List.NonEmpty qualified as NE+import Data.Map qualified as Map import GHC.Types.SrcLoc import GHC.Hs import GHC.Utils.Outputable-import GHC.Data.Bag import GHC.Util import Language.Haskell.GhclibParserEx.GHC.Hs import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances@@ -53,14 +53,14 @@ dupes [ (m, d, y) | (m, d, x) <- ds , HsValBinds _ (ValBinds _ b _ ) :: HsLocalBinds GhcPs <- universeBi x- , let y = bagToList b+ , let y = b ] where ds = [(modName m, fromMaybe "" (declName d), unLoc d)- | ModuleEx m _ <- map snd ms+ | ModuleEx m <- map snd ms , d <- hsmodDecls (unLoc m)] -dupes :: (Outputable e, Data e) => [(String, String, [Located e])] -> [Idea]+dupes :: (Outputable e, Data e) => [(String, String, [LocatedA e])] -> [Idea] dupes ys = [(rawIdeaN (if length xs >= 5 then Hint.Type.Warning else Suggestion)@@ -72,7 +72,7 @@ | ((m1, d1, SrcSpanD p1), (m2, d2, SrcSpanD p2), xs) <- duplicateOrdered 3 $ map f ys] where f (m, d, xs) =- [((m, d, SrcSpanD (getLoc x)), extendInstances (stripLocs x)) | x <- xs]+ [((m, d, SrcSpanD (locA (getLoc x))), extendInstances (stripLocs x)) | x <- xs] --------------------------------------------------------------------- -- DUPLICATE FINDING
src/Hint/Export.hs view
@@ -16,15 +16,14 @@ import Hint.Type(ModuHint, ModuleEx(..),ideaNote,ignore,Note(..)) import GHC.Hs-import GHC.Unit.Module import GHC.Types.SrcLoc import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader exportHint :: ModuHint-exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) _)+exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) ) | Nothing <- exports =- let r = o{ hsmodExports = Just (noLoc [noLoc (IEModuleContents noExtField name)] )} in+ let r = o{ hsmodExports = Just (noLocA [noLocA (IEModuleContents (Nothing, noAnn) name)] )} in [(ignore "Use module export list" (L s o) (noLoc r) []){ideaNote = [Note "an explicit list is usually better"]}] | Just (L _ xs) <- exports , mods <- [x | x <- xs, isMod x]@@ -33,11 +32,11 @@ , exports' <- [x | x <- xs, not (matchesModName modName x)] , modName `elem` names = let dots = mkRdrUnqual (mkVarOcc " ... ")- r = o{ hsmodExports = Just (noLoc (noLoc (IEVar noExtField (noLoc (IEName (noLoc dots)))) : exports') )}+ r = o{ hsmodExports = Just (noLocA (noLocA (IEVar Nothing (noLocA (IEName noExtField (noLocA dots))) Nothing) : exports') )} in [ignore "Use explicit module export list" (L s o) (noLoc r) []] where- o = m{hsmodImports=[], hsmodDecls=[], hsmodDeprecMessage=Nothing, hsmodHaddockModHeader=Nothing }+ o = m{hsmodImports=[], hsmodDecls=[] } isMod (L _ (IEModuleContents _ _)) = True isMod _ = False
src/Hint/Extensions.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE LambdaCase, NamedFieldPuns #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase, NamedFieldPuns, ScopedTypeVariables #-} {- Suggest removal of unnecessary extensions@@ -15,7 +16,9 @@ {-# LANGUAGE TemplateHaskell #-} \ $(deriveNewtypes typeInfo) {-# LANGUAGE TemplateHaskell #-} \-main = foo ''Bar+main = foo ''Bar --+{-# LANGUAGE QuasiQuotes, TemplateHaskell #-} \+f x = x + [e| x + 1 |] + [foo| x + 1 |] -- {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE PatternGuards #-} \ test = case x of _ | y <- z -> w {-# LANGUAGE TemplateHaskell,EmptyDataDecls #-} \@@ -95,6 +98,8 @@ deriving instance Show Bar -- {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} \ newtype Micro = Micro Int deriving Generic -- {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric, TypeFamilies #-} \+data family Bar a; data instance Bar Foo = Foo deriving Generic {-# LANGUAGE GeneralizedNewtypeDeriving #-} \ instance Class Int where {newtype MyIO a = MyIO a deriving NewClass} {-# LANGUAGE UnboxedTuples #-} \@@ -120,6 +125,8 @@ foo = id -- {-# LANGUAGE TypeApplications #-} \ foo = id @Int+{-# LANGUAGE TypeApplications #-} \+x :: Typeable b => TypeRep @Bool b {-# LANGUAGE LambdaCase #-} \ foo = id -- {-# LANGUAGE LambdaCase #-} \@@ -228,13 +235,34 @@ data T m a = MkT (m a) (T Maybe (m a)) {-# LANGUAGE NoMonomorphismRestriction, NamedFieldPuns #-} \ main = 1 -- @Note Extension NamedFieldPuns is not used+{-# LANGUAGE FunctionalDependencies #-} \+class HasField x r a | x r -> a+{-# LANGUAGE OverloadedRecordDot #-} \+f x = x.foo+{-# LANGUAGE OverloadedRecordDot #-} \+f x = x . foo -- @NoRefactor: refactor requires GHC >= 9.2.1+{-# LANGUAGE OverloadedRecordDot #-} \+f = (.foo)+{-# LANGUAGE OverloadedRecordDot #-} \+f = (. foo) -- @NoRefactor: refactor requires GHC >= 9.2.1+{-# LANGUAGE TemplateHaskellQuotes #-} \+foo = [|| x ||]+{-# LANGUAGE TemplateHaskell #-} \+foo = $bar+{-# LANGUAGE TemplateHaskell #-} \+foo = $$typedExpressionSplice+{-# LANGUAGE TypeData # -} \+type data Nat = Zero | Succ Nat -- @NoRefactor: refactor requires GHC >= 9.6.1+{-# LANGUAGE TypeData #-} \+data T = MkT -- @NoRefactor: refactor requires GHC >= 9.6.1 </TEST> -} + module Hint.Extensions(extensionsHint) where -import Hint.Type(ModuHint,rawIdea,Severity(Warning),Note(..),toSS,ghcAnnotations,ghcModule)+import Hint.Type(ModuHint,rawIdea,Severity(Warning),Note(..),toSSAnc,ghcModule,modComments,firstDeclComments) import Extension import Data.Generics.Uniplate.DataOnly@@ -243,22 +271,25 @@ import Data.List.Extra import Data.Data import Refact.Types-import qualified Data.Set as Set-import qualified Data.Map as Map+import Data.Set qualified as Set+import Data.Map qualified as Map +import GHC.Data.FastString import GHC.Types.SrcLoc+import GHC.Types.SourceText import GHC.Hs import GHC.Types.Basic-import GHC.Core.Class import GHC.Types.Name.Reader import GHC.Types.ForeignCall+import GHC.Data.Strict qualified+import GHC.Types.PkgQual import GHC.Util import GHC.LanguageExtensions.Type import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr-import Language.Haskell.GhclibParserEx.GHC.Hs.Types+import Language.Haskell.GhclibParserEx.GHC.Hs.Type import Language.Haskell.GhclibParserEx.GHC.Hs.Decls import Language.Haskell.GhclibParserEx.GHC.Hs.Binds import Language.Haskell.GhclibParserEx.GHC.Hs.ImpExp@@ -268,15 +299,22 @@ extensionsHint :: ModuHint extensionsHint _ x =- [ rawIdea Hint.Type.Warning "Unused LANGUAGE pragma"- sl- (comment (mkLanguagePragmas sl exts))+ [+ rawIdea Hint.Type.Warning "Unused LANGUAGE pragma"+ (RealSrcSpan (epaLocationRealSrcSpan sl) GHC.Data.Strict.Nothing)+ (comment_ (mkLanguagePragmas sl exts)) (Just newPragma) ( [RequiresExtension (show gone) | (_, Just x) <- before \\ after, gone <- Map.findWithDefault [] x disappear] ++ [ Note $ "Extension " ++ s ++ " is " ++ reason x | (s, Just x) <- explainedRemovals])- [ModifyComment (toSS (mkLanguagePragmas sl exts)) newPragma]- | (L sl _, exts) <- languagePragmas $ pragmas (ghcAnnotations x)+ [ModifyComment (toSSAnc (mkLanguagePragmas sl exts)) newPragma]+ | (L sl _, exts) <-+ -- Comments appearing without an empty line before the first+ -- declaration in a module are now associated with the+ -- declaration not the module so to be safe, look also at+ -- `firstDeclComments x`+ -- (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).+ languagePragmas $ pragmas (modComments x) ++ pragmas (firstDeclComments x) , let before = [(x, readExtension x) | x <- exts] , let after = filter (maybe True (`Set.member` keep) . snd) before , before /= after@@ -284,22 +322,35 @@ | null after && not (any (`Map.member` implied) $ mapMaybe snd before) = [] | otherwise = before \\ after , let newPragma =- if null after then "" else comment (mkLanguagePragmas sl $ map fst after)+ if null after then "" else comment_ (mkLanguagePragmas sl $ map fst after) ] where usedTH :: Bool- usedTH = used TemplateHaskell (ghcModule x) || used QuasiQuotes (ghcModule x)+ usedTH = used TemplateHaskell (ghcModule x)+ || used TemplateHaskellQuotes (ghcModule x)+ || used QuasiQuotes (ghcModule x) -- If TH or QuasiQuotes is on, can use all other extensions -- programmatically. -- All the extensions defined to be used. extensions :: Set.Set Extension- extensions = Set.fromList $ mapMaybe readExtension $- concatMap snd $ languagePragmas (pragmas (ghcAnnotations x))+ extensions = Set.fromList $+ concatMap+ (mapMaybe readExtension . snd)+ (languagePragmas+ (pragmas (modComments x) ++ pragmas (firstDeclComments x)))+ -- Comments appearing without an empty line before the first+ -- declaration in a module are now associated with the+ -- declaration not the module so to be safe, look also at+ -- `firstDeclComments x`+ -- (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517). -- Those extensions we detect to be useful. useful :: Set.Set Extension- useful = if usedTH then extensions else Set.filter (`usedExt` ghcModule x) extensions+ useful =+ if usedTH+ then Set.filter (\case TemplateHaskell -> usedExt TemplateHaskell (ghcModule x); _ -> True) extensions+ else Set.filter (`usedExt` ghcModule x) extensions -- Those extensions which are useful, but implied by other useful -- extensions. implied :: Map.Map Extension Extension@@ -342,7 +393,7 @@ deriveStock :: [String] deriveStock = deriveHaskell ++ deriveGenerics ++ deriveCategory -usedExt :: Extension -> Located HsModule -> Bool+usedExt :: Extension -> Located (HsModule GhcPs) -> Bool usedExt NumDecimals = hasS isWholeFrac -- Only whole number fractions are permitted by NumDecimals -- extension. Anything not-whole raises an error.@@ -350,38 +401,39 @@ usedExt DeriveAnyClass = not . null . derivesAnyclass . derives usedExt x = used x --- The ghc-lib-parser-ex functions are getting fixed to have the new--- signatures.-isMDo' :: HsStmtContext GhcRn -> Bool-isMDo' = \case MDoExpr _ -> True; _ -> False-isStrictMatch' :: HsMatchContext GhcPs -> Bool-isStrictMatch' = \case FunRhs{mc_strictness=SrcStrict} -> True; _ -> False--used :: Extension -> Located HsModule -> Bool+used :: Extension -> Located (HsModule GhcPs) -> Bool -used RecursiveDo = hasS isMDo' ||^ hasS isRecStmt+used RecursiveDo = hasS isMDo ||^ hasS isRecStmt used ParallelListComp = hasS isParComp-used FunctionalDependencies = hasT (un :: FunDep (Located RdrName))+used FunctionalDependencies = hasT (un :: FunDep GhcPs) used ImplicitParams = hasT (un :: HsIPName)-used TypeApplications = hasS isTypeApp++used TypeApplications = hasS isTypeApp ||^ hasS isKindTyApp+ used EmptyDataDecls = hasS f where f :: HsDataDefn GhcPs -> Bool- f (HsDataDefn _ _ _ _ _ [] _) = True+ f (HsDataDefn _ _ _ _ (DataTypeCons _ []) _) = True f _ = False+used TypeData = hasS f+ where+ f :: HsDataDefn GhcPs -> Bool+ f (HsDataDefn _ _ _ _ (DataTypeCons True _) _) = True+ f _ = False used EmptyCase = hasS f where f :: HsExpr GhcPs -> Bool- f (HsCase _ _ (MG _ (L _ []) _)) = True- f (HsLamCase _ (MG _ (L _ []) _)) = True+ f (HsCase _ _ (MG _ (L _ []))) = True+ f (HsLam _ LamCase (MG _ (L _ []))) = True f _ = False used KindSignatures = hasT (un :: HsKind GhcPs)-used BangPatterns = hasS isPBangPat ||^ hasS isStrictMatch'-used TemplateHaskell = hasT2' (un :: (HsBracket GhcPs, HsSplice GhcPs)) ||^ hasS f ||^ hasS isSpliceDecl+used BangPatterns = hasS isPBangPat ||^ hasS isStrictMatch+used TemplateHaskell = hasS (not . isQuasiQuoteSplice) ||^ hasS isTypedSplice+used TemplateHaskellQuotes = hasS f where- f :: HsBracket GhcPs -> Bool- f VarBr{} = True- f TypBr{} = True+ f :: HsExpr GhcPs -> Bool+ f HsTypedBracket{} = True+ f HsUntypedBracket{} = True f _ = False used ForeignFunctionInterface = hasT (un :: CCallConv) used PatternGuards = hasS f@@ -410,7 +462,7 @@ isOp (L _ name) = isSymbolRdrName name used RecordWildCards = hasS hasFieldsDotDot ||^ hasS hasPFieldsDotDot-used RecordPuns = hasS isPFieldPun ||^ hasS isFieldPun ||^ hasS isFieldPunUpdate+used NamedFieldPuns = hasS isPFieldPun ||^ hasS isFieldPun ||^ hasS isFieldPunUpdate used UnboxedTuples = hasS isUnboxedTuple ||^ hasS (== Unboxed) ||^ hasS isDeriving where -- detect if there are deriving declarations or data ... deriving stuff@@ -421,9 +473,9 @@ used PackageImports = hasS f where f :: ImportDecl GhcPs -> Bool- f ImportDecl{ideclPkgQual=Just _} = True+ f ImportDecl{ideclPkgQual=RawPkgQual _} = True f _ = False-used QuasiQuotes = hasS isQuasiQuote ||^ hasS isTyQuasiQuote+used QuasiQuotes = hasS isQuasiQuoteExpr ||^ hasS isTyQuasiQuote used ViewPatterns = hasS isPViewPat used InstanceSigs = hasS f where@@ -441,8 +493,8 @@ used NumericUnderscores = hasS f where f :: OverLitVal -> Bool- f (HsIntegral (IL (SourceText t) _ _)) = '_' `elem` t- f (HsFractional (FL (SourceText t) _ _)) = '_' `elem` t+ f (HsIntegral (IL (SourceText t) _ _)) = '_' `elem` unpackFS t+ f (HsFractional (FL (SourceText t) _ _ _ _)) = '_' `elem` unpackFS t f _ = False used LambdaCase = hasS isLCase@@ -460,11 +512,7 @@ isListPat ListPat{} = True isListPat _ = False -used OverloadedLabels = hasS isLabel- where- isLabel :: HsExpr GhcPs -> Bool- isLabel HsOverLabel{} = True- isLabel _ = False+used OverloadedLabels = hasS isOverLabel used Arrows = hasS isProc used TransformListComp = hasS isTransStmt@@ -475,10 +523,11 @@ used PatternSynonyms = hasS isPatSynBind ||^ hasS isPatSynIE used ImportQualifiedPost = hasS (== QualifiedPost) used StandaloneKindSignatures = hasT (un :: StandaloneKindSig GhcPs)+used OverloadedRecordDot = hasT (un :: DotFieldOcc GhcPs) used _= const True -hasDerive :: [String] -> Located HsModule -> Bool+hasDerive :: [String] -> Located (HsModule GhcPs) -> Bool hasDerive want = any (`elem` want) . derivesStock' . derives -- Derivations can be implemented using any one of 3 strategies, so for each derivation@@ -497,32 +546,36 @@ addDerives :: Maybe NewOrData -> Maybe (DerivStrategy GhcPs) -> [String] -> Derives addDerives _ (Just s) xs = case s of- StockStrategy -> mempty{derivesStock' = xs}- AnyclassStrategy -> mempty{derivesAnyclass = xs}- NewtypeStrategy -> mempty{derivesNewtype' = xs}- ViaStrategy{} -> mempty+ StockStrategy {} -> mempty{derivesStock' = xs}+ AnyclassStrategy {} -> mempty{derivesAnyclass = xs}+ NewtypeStrategy {} -> mempty{derivesNewtype' = xs}+ ViaStrategy {} -> mempty addDerives nt _ xs = mempty {derivesStock' = stock ,derivesAnyclass = other ,derivesNewtype' = if maybe True isNewType nt then filter (`notElem` noDeriveNewtype) xs else []} where (stock, other) = partition (`elem` deriveStock) xs -derives :: Located HsModule -> Derives+derives :: Located (HsModule GhcPs) -> Derives derives (L _ m) = mconcat $ map decl (childrenBi m) ++ map idecl (childrenBi m) where- idecl :: Located (DataFamInstDecl GhcPs) -> Derives- idecl (L _ (DataFamInstDecl (HsIB _ FamEqn {feqn_rhs=HsDataDefn {dd_ND=dn, dd_derivs=(L _ ds)}}))) = g dn ds+ idecl :: DataFamInstDecl GhcPs -> Derives+ idecl (DataFamInstDecl FamEqn {feqn_rhs=HsDataDefn {dd_cons=data_defn_cons, dd_derivs=ds}}) = g (dataDefnConsNewOrData data_defn_cons) ds decl :: LHsDecl GhcPs -> Derives- decl (L _ (TyClD _ (DataDecl _ _ _ _ HsDataDefn {dd_ND=dn, dd_derivs=(L _ ds)}))) = g dn ds -- Data declaration.+ decl (L _ (TyClD _ (DataDecl _ _ _ _ HsDataDefn {dd_cons=data_defn_cons, dd_derivs=ds}))) = g (dataDefnConsNewOrData data_defn_cons) ds -- Data declaration. decl (L _ (DerivD _ (DerivDecl _ (HsWC _ sig) strategy _))) = addDerives Nothing (fmap unLoc strategy) [derivedToStr sig] -- A deriving declaration. decl _ = mempty g :: NewOrData -> [LHsDerivingClause GhcPs] -> Derives- g dn ds = mconcat [addDerives (Just dn) (fmap unLoc strategy) $ map derivedToStr tys | L _ (HsDerivingClause _ strategy (L _ tys)) <- ds]+ g dn ds = mconcat [addDerives (Just dn) (fmap unLoc strategy) $ map derivedToStr tys | (strategy, tys) <- stys]+ where+ stys =+ [(strategy, [ty]) | L _ (HsDerivingClause _ strategy (L _ (DctSingle _ ty))) <- ds] +++ [(strategy, tys ) | L _ (HsDerivingClause _ strategy (L _ (DctMulti _ tys))) <- ds] derivedToStr :: LHsSigType GhcPs -> String- derivedToStr (HsIB _ t) = ih t+ derivedToStr (L _ (HsSig _ _ t)) = ih t where ih :: LHsType GhcPs -> String ih (L _ (HsQualTy _ _ a)) = ih a@@ -534,7 +587,6 @@ un = undefined hasT t x = not $ null (universeBi x `asTypeOf` [t])-hasT2' ~(t1,t2) = hasT t1 ||^ hasT t2 hasS :: (Data x, Data a) => (a -> Bool) -> x -> Bool hasS test = any test . universeBi
src/Hint/Fixities.hs view
@@ -16,7 +16,7 @@ module Hint.Fixities(fixitiesHint) where -import Hint.Type(DeclHint,Idea(..),rawIdea,toSS)+import Hint.Type(DeclHint,Idea(..),rawIdea,toSSA) import Config.Type import Control.Monad import Data.List.Extra@@ -24,7 +24,7 @@ import Data.Generics.Uniplate.DataOnly import Refact.Types -import GHC.Types.Basic (compareFixity)+import GHC.Types.Fixity(compareFixity) import Fixity import GHC.Hs import GHC.Util@@ -51,8 +51,8 @@ Just x <- [remParen v] guard $ redundantInfixBracket fixities i o x pure $- rawIdea Ignore msg (getLoc v) (unsafePrettyPrint o)- (Just (unsafePrettyPrint (gen x))) [] [Replace (findType v) (toSS v) [("x", toSS x)] "x"]+ rawIdea Ignore msg (locA (getLoc v)) (unsafePrettyPrint o)+ (Just (unsafePrettyPrint (gen x))) [] [Replace (findType v) (toSSA v) [("x", toSSA x)] "x"] redundantInfixBracket :: Map String Fixity -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool redundantInfixBracket fixities i parent child@@ -62,7 +62,7 @@ | i == 0 = (c, p) | otherwise = (p, c) in- case compareFixity <$> (fixities !? occNameString lop) <*> (fixities !? occNameString rop) of+ case compareFixity <$> (fixities Data.Map.!? occNameString lop) <*> (fixities Data.Map.!? occNameString rop) of Just (False, r) | i == 0 -> not (needParenAsChild cr || r) | otherwise -> r@@ -73,7 +73,6 @@ needParenAsChild HsLet{} = True needParenAsChild HsDo{} = True needParenAsChild HsLam{} = True-needParenAsChild HsLamCase{} = True needParenAsChild HsCase{} = True needParenAsChild HsIf{} = True needParenAsChild _ = False
src/Hint/Import.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase, PatternGuards, RecordWildCards #-} {- Reduce the number of import declarations.@@ -37,9 +38,9 @@ module Hint.Import(importHint) where -import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),suggest,toSS,rawIdea)+import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),suggest,toSSA,rawIdea) import Refact.Types hiding (ModuleName)-import qualified Refact.Types as R+import Refact.Types qualified as R import Data.Tuple.Extra import Data.List.Extra import Data.Generics.Uniplate.DataOnly@@ -48,13 +49,18 @@ import Prelude import GHC.Data.FastString-import GHC.Types.Basic+import GHC.Types.SourceText import GHC.Hs import GHC.Types.SrcLoc-import GHC.Unit.Types -- for 'NotBoot'+import GHC.Types.PkgQual import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable +rawPkgQualToMaybe :: RawPkgQual -> Maybe StringLiteral+rawPkgQualToMaybe x =+ case x of+ NoRawPkgQual -> Nothing+ RawPkgQual lit -> Just lit importHint :: ModuHint importHint _ ModuleEx {ghcModule=L _ HsModule{hsmodImports=ms}} =@@ -64,14 +70,14 @@ , ideclSource (unLoc i) == NotBoot , let i' = unLoc i , let n = unLoc $ ideclName i'- , let pkg = unpackFS . sl_fs <$> ideclPkgQual i']) +++ , let pkg = unpackFS . sl_fs <$> rawPkgQualToMaybe (ideclPkgQual i')]) ++ -- Ideas for removing redundant 'as' clauses. concatMap stripRedundantAlias ms reduceImports :: [LImportDecl GhcPs] -> [Idea] reduceImports [] = [] reduceImports ms@(m:_) =- [rawIdea Hint.Type.Warning "Use fewer imports" (getLoc m) (f ms) (Just $ f x) [] rs+ [rawIdea Hint.Type.Warning "Use fewer imports" (locA (getLoc m)) (f ms) (Just $ f x) [] rs | Just (x, rs) <- [simplify ms]] where f = unlines . map unsafePrettyPrint @@ -97,29 +103,29 @@ -> Maybe (LImportDecl GhcPs, [Refactoring R.SrcSpan]) combine x@(L loc x') y@(L _ y') -- Both (un/)qualified, common 'as', same names : Delete the second.- | qual, as, specs = Just (x, [Delete Import (toSS y)])+ | qual, as, specs = Just (x, [Delete Import (toSSA y)]) -- Both (un/)qualified, common 'as', different names : Merge the -- second into the first and delete it. | qual, as- , Just (False, xs) <- ideclHiding x'- , Just (False, ys) <- ideclHiding y' =- let newImp = L loc x'{ideclHiding = Just (False, noLoc (unLoc xs ++ unLoc ys))}- in Just (newImp, [Replace Import (toSS x) [] (unsafePrettyPrint (unLoc newImp))- , Delete Import (toSS y)])+ , Just (False, xs) <- first (== EverythingBut) <$> ideclImportList x'+ , Just (False, ys) <- first (== EverythingBut) <$> ideclImportList y' =+ let newImp = L loc x'{ideclImportList = Just (Exactly, noLocA (unLoc xs ++ unLoc ys))}+ in Just (newImp, [Replace Import (toSSA x) [] (unsafePrettyPrint (unLoc newImp))+ , Delete Import (toSSA y)]) -- Both (un/qualified), common 'as', one has names the other doesn't -- : Delete the one with names.- | qual, as, isNothing (ideclHiding x') || isNothing (ideclHiding y') =- let (newImp, toDelete) = if isNothing (ideclHiding x') then (x, y) else (y, x)- in Just (newImp, [Delete Import (toSS toDelete)])+ | qual, as, isNothing (ideclImportList x') || isNothing (ideclImportList y') =+ let (newImp, toDelete) = if isNothing (ideclImportList x') then (x, y) else (y, x)+ in Just (newImp, [Delete Import (toSSA toDelete)]) -- Both unqualified, same names, one (and only one) has an 'as' -- clause : Delete the one without an 'as'. | ideclQualified x' == NotQualified, qual, specs, length ass == 1 = let (newImp, toDelete) = if isJust (ideclAs x') then (x, y) else (y, x)- in Just (newImp, [Delete Import (toSS toDelete)])+ in Just (newImp, [Delete Import (toSSA toDelete)]) -- No hints. | otherwise = Nothing where- eqMaybe:: Eq a => Maybe (Located a) -> Maybe (Located a) -> Bool+ eqMaybe:: Eq a => Maybe (LocatedA a) -> Maybe (LocatedA a) -> Bool eqMaybe (Just x) (Just y) = x `eqLocated` y eqMaybe Nothing Nothing = True eqMaybe _ _ = False@@ -127,12 +133,12 @@ qual = ideclQualified x' == ideclQualified y' as = ideclAs x' `eqMaybe` ideclAs y' ass = mapMaybe ideclAs [x', y']- specs = transformBi (const noSrcSpan) (ideclHiding x') ==- transformBi (const noSrcSpan) (ideclHiding y')+ specs = transformBi (const noSrcSpan) (ideclImportList x') ==+ transformBi (const noSrcSpan) (ideclImportList y') stripRedundantAlias :: LImportDecl GhcPs -> [Idea]-stripRedundantAlias x@(L loc i@ImportDecl {..})+stripRedundantAlias x@(L _ i@ImportDecl {..}) -- Suggest 'import M as M' be just 'import M'. | Just (unLoc ideclName) == fmap unLoc ideclAs =- [suggest "Redundant as" x (L loc i{ideclAs=Nothing} :: LImportDecl GhcPs) [RemoveAsKeyword (toSS x)]]+ [suggest "Redundant as" (reLoc x) (noLoc i{ideclAs=Nothing} :: Located (ImportDecl GhcPs)) [RemoveAsKeyword (toSSA x)]] stripRedundantAlias _ = []
src/Hint/Lambda.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE LambdaCase, PatternGuards, ViewPatterns #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase, PatternGuards, TupleSections, ViewPatterns #-} {- Concept:@@ -32,10 +33,11 @@ fun x y z = f x x y z -- fun x = f x x fun x y z = f g z -- fun x y = f g fun x = f . g $ x -- fun = f . g+fun a b = f a b c where g x y = h x y -- g = h+fun a b = let g x y = h x y in f a b c -- g = h f = foo (\y -> g x . h $ y) -- g x . h f = foo (\y -> g x . h $ y) -- @Message Avoid lambda f = foo ((*) x) -- (x *)-f = foo ((Prelude.*) x) -- (x Prelude.*) f = (*) x f = foo (flip op x) -- (`op` x) f = foo (flip op x) -- @Message Use section@@ -85,6 +87,7 @@ yes = blah (\ x -> case x of A -> a; B -> b) -- \ case A -> a; B -> b yes = blah (\ x -> case x of A -> a; B -> b) -- @Note may require `{-# LANGUAGE LambdaCase #-}` adding to the top of the file no = blah (\ x -> case x of A -> a x; B -> b x)+no = blah (\ x -> case x of A -> a x; x -> b x) foo = bar (\x -> case x of Y z | z > 0 -> z) -- \case Y z | z > 0 -> z yes = blah (\ x -> (y, x)) -- (y,) yes = blah (\ x -> (y, x, z+q)) -- (y, , z+q)@@ -105,20 +108,22 @@ module Hint.Lambda(lambdaHint) where -import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, suggestN, ideaNote, substVars, toRefactSrcSpan)+import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, toSSA, suggestN, ideaNote, substVars, toRefactSrcSpan) import Util import Data.List.Extra import Data.Set (Set)-import qualified Data.Set as Set-import Refact.Types hiding (RType(Match))+import Data.Set qualified as Set+import Refact.Types hiding (Match) import Data.Generics.Uniplate.DataOnly (universe, universeBi, transformBi) import GHC.Types.Basic+import GHC.Types.Fixity import GHC.Hs import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader import GHC.Types.SrcLoc-import Language.Haskell.GhclibParserEx.GHC.Hs.Expr (isTypeApp, isOpApp, isLambda, isQuasiQuote, isVar, isDol, strToVar)+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr (isTypeApp, isOpApp, isLambda, isQuasiQuoteExpr, isVar, isDol, strToVar)+import Language.Haskell.GhclibParserEx.GHC.Hs.Pat (isWildPat) import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import GHC.Util.Brackets (isAtom)@@ -129,52 +134,59 @@ lambdaHint :: DeclHint lambdaHint _ _ x = concatMap (uncurry lambdaExp) (universeParentBi x)- ++ concatMap lambdaDecl (universe x)+ ++ concatMap (uncurry lambdaBind) binds+ where+ binds =+ ( case x of+ -- Turn a top-level HsBind under a ValD into an LHsBind.+ -- Also, its refact type needs to be Decl.+ L loc (ValD _ bind) -> ((L loc bind, Decl) :)+ _ -> id+ )+ ((,Bind) <$> universeBi x) -lambdaDecl :: LHsDecl GhcPs -> [Idea]-lambdaDecl- o@(L _ (ValD _- origBind@FunBind {fun_id = funName@(L loc1 _), fun_matches =- MG {mg_alts =- L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _) pats (GRHSs _ [L _ (GRHS _ [] origBody@(L loc2 _))] bind))]}}))- | L _ (EmptyLocalBinds _) <- bind+lambdaBind :: LHsBind GhcPs -> RType -> [Idea]+lambdaBind+ o@(L _ origBind@FunBind {fun_id = funName@(L loc1 _), fun_matches =+ MG {mg_alts =+ L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _ _) (L _ pats) (GRHSs _ [L _ (GRHS _ [] origBody@(L loc2 _))] bind))]}}) rtype+ | EmptyLocalBinds _ <- bind , isLambda $ fromParen origBody , null (universeBi pats :: [HsExpr GhcPs]) = let (newPats, newBody) = fromLambda . lambda pats $ origBody (sub, tpl) = mkSubtsAndTpl newPats newBody- gen :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs+ gen :: [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs) gen ps = uncurry reform . fromLambda . lambda ps refacts = case newBody of -- https://github.com/alanz/ghc-exactprint/issues/97 L _ HsCase{} -> []- _ -> [Replace Decl (toSS o) sub tpl]- in [warn "Redundant lambda" o (gen pats origBody) refacts]+ _ -> [Replace rtype (toSSA o) sub tpl]+ in [warn "Redundant lambda" (reLoc o) (gen pats origBody) refacts] | let (newPats, newBody) = etaReduce pats origBody , length newPats < length pats, pvars (drop (length newPats) pats) `disjoint` varss bind = let (sub, tpl) = mkSubtsAndTpl newPats newBody in [warn "Eta reduce" (reform pats origBody) (reform newPats newBody)- [Replace Decl (toSS $ reform pats origBody) sub tpl]+ [Replace rtype (toSS $ reform pats origBody) sub tpl] ]- where reform :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs- reform ps b = L (combineSrcSpans loc1 loc2) $ ValD noExtField $- origBind- {fun_matches = MG noExtField (noLoc [noLoc $ Match noExtField ctxt ps $ GRHSs noExtField [noLoc $ GRHS noExtField [] b] $ noLoc $ EmptyLocalBinds noExtField]) Generated}+ where+ reform :: [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)+ reform ps b = L (combineSrcSpans (locA loc1) (locA loc2)) $ ValD noExtField $+ origBind {fun_matches = MG (Generated OtherExpansion SkipPmc) (noLocA [noLocA $ Match noExtField ctxt (L noSpanAnchor ps) $ GRHSs emptyComments [noLocA $ GRHS noAnn [] b] $ EmptyLocalBinds noExtField])} mkSubtsAndTpl newPats newBody = (sub, tpl) where (origPats, vars) = mkOrigPats (Just (rdrNameStr funName)) newPats- sub = ("body", toSS newBody) : zip vars (map toSS newPats)+ sub = ("body", toSSA newBody) : zip vars (map toSSA newPats) tpl = unsafePrettyPrint (reform origPats varBody) -lambdaDecl _ = []-+lambdaBind _ _ = [] etaReduce :: [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs) etaReduce (unsnoc -> Just (ps, view -> PVar_ p)) (L _ (HsApp _ x (view -> Var_ y))) | p == y , y `notElem` vars x- , not $ any isQuasiQuote $ universe x+ , not $ any isQuasiQuoteExpr $ universe x = etaReduce ps x etaReduce ps (L loc (OpApp _ x (isDol -> True) y)) = etaReduce ps (L loc (HsApp noExtField x y)) etaReduce ps x = (ps, x)@@ -185,28 +197,29 @@ , isAtom y , allowLeftSection $ occNameString f , not $ isTypeApp y- = [suggest "Use section" o to [r]]+ = [suggest "Use section" (reLoc o) (reLoc to) [r]] where to :: LHsExpr GhcPs- to = noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField y oper- r = Replace Expr (toSS o) [("x", toSS y)] ("(x " ++ unsafePrettyPrint origf ++ ")")+ to = nlHsPar $ noLocA $ SectionL noExtField y oper+ r = Replace Expr (toSSA o) [("x", toSSA y)] ("(x " ++ unsafePrettyPrint origf ++ ")") lambdaExp _ o@(L _ (HsPar _ (view -> App2 (view -> Var_ "flip") origf@(view -> RdrName_ f) y))) | allowRightSection (rdrNameStr f), not $ "(" `isPrefixOf` rdrNameStr f- = [suggest "Use section" o to [r]]+ = [suggest "Use section" (reLoc o) (reLoc to) [r]] where to :: LHsExpr GhcPs- to = noLoc $ HsPar noExtField $ noLoc $ SectionR noExtField origf y+ to = nlHsPar $ noLocA $ SectionR noExtField origf y op = if isSymbolRdrName (unLoc f) then unsafePrettyPrint f else "`" ++ unsafePrettyPrint f ++ "`" var = if rdrNameStr f == "x" then "y" else "x"- r = Replace Expr (toSS o) [(var, toSS y)] ("(" ++ op ++ " " ++ var ++ ")")-lambdaExp p o@(L _ HsLam{})+ r = Replace Expr (toSSA o) [(var, toSSA y)] ("(" ++ op ++ " " ++ var ++ ")")++lambdaExp p o@(L _ (HsLam _ LamSingle _)) | not $ any isOpApp p , (res, refact) <- niceLambdaR [] o , not $ isLambda res- , not $ any isQuasiQuote $ universe res+ , not $ any isQuasiQuoteExpr $ universe res , not $ "runST" `Set.member` Set.map occNameString (freeVars o) , let name = "Avoid lambda" ++ (if countRightSections res > countRightSections o then " using `infix`" else "") -- If the lambda's parent is an HsPar, and the result is also an HsPar, the span should include the parentheses.@@ -216,7 +229,7 @@ | L _ HsPar{} <- res -> p | L _ (HsVar _ (L _ name)) <- res, not (isSymbolRdrName name) -> p _ -> o- = [(if isVar res then warn else suggest) name from res (refact $ toSS from)]+ = [(if isVar res then warn else suggest) name (reLoc from) (reLoc res) (refact $ toSSA from)] where countRightSections :: LHsExpr GhcPs -> Int countRightSections x = length [() | L _ (SectionR _ (view -> Var_ _) _) <- universe x]@@ -225,11 +238,11 @@ | isLambda (fromParen origBody) , null (universeBi origPats :: [HsExpr GhcPs]) -- TODO: I think this checks for view patterns only, so maybe be more explicit about that? , maybe True (not . isLambda) p =- [suggest "Collapse lambdas" o (lambda pats body) [Replace Expr (toSS o) subts template]]+ [suggest "Collapse lambdas" (reLoc o) (reLoc (lambda pats body)) [Replace Expr (toSSA o) subts template]] where (pats, body) = fromLambda o (oPats, vars) = mkOrigPats Nothing pats- subts = ("body", toSS body) : zip vars (map toSS pats)+ subts = ("body", toSSA body) : zip vars (map toSSA pats) template = unsafePrettyPrint (lambda oPats varBody) -- match a lambda with a variable pattern, with no guards and no where clauses@@ -241,9 +254,8 @@ | ([_x], ys) <- partition ((==Just x) . tupArgVar) args -- the other arguments must not have a nested x somewhere in them , Set.notMember x $ Set.map occNameString $ freeVars ys- -> [(suggestN "Use tuple-section" o $ noLoc $ ExplicitTuple noExtField (map removeX args) boxity)+ -> [(suggestN "Use tuple-section" (reLoc o) $ noLoc $ ExplicitTuple noAnn (map removeX args) boxity) {ideaNote = [RequiresExtension "TupleSections"]}]- -- suggest @LambdaCase@/directly matching in a lambda instead of doing @\x -> case x of ...@ HsCase _ (view -> Var_ x') matchGroup -- is the case being done on the variable from our original lambda?@@ -256,48 +268,48 @@ -- we need to -- * add brackets to the match, because matches in lambdas require them -- * mark match as being in a lambda context so that it's printed properly- oldMG@(MG _ (L _ [L _ oldmatch]) _)+ oldMG@(MG _ (L _ [L _ oldmatch])) | all (\(L _ (GRHS _ stmts _)) -> null stmts) (grhssGRHSs (m_grhss oldmatch)) ->- let patLocs = fmap getLoc (m_pats oldmatch)- bodyLocs = concatMap (\case L _ (GRHS _ _ body) -> [getLoc body])+ let patLocs = fmap (locA . getLoc) ((unLoc . m_pats) oldmatch)+ bodyLocs = concatMap (\case L _ (GRHS _ _ body) -> [locA (getLoc body)]) $ grhssGRHSs (m_grhss oldmatch) r | notNull patLocs && notNull bodyLocs = let xloc = foldl1' combineSrcSpans patLocs yloc = foldl1' combineSrcSpans bodyLocs- in [ Replace Expr (toSS o) [("x", toRefactSrcSpan xloc), ("y", toRefactSrcSpan yloc)]+ in [ Replace Expr (toSSA o) [("x", toRefactSrcSpan xloc), ("y", toRefactSrcSpan yloc)] ((if needParens then "\\(x)" else "\\x") ++ " -> y") ] | otherwise = []- needParens = any (patNeedsParens appPrec . unLoc) (m_pats oldmatch)- in [ suggest "Use lambda" o- ( noLoc $ HsLam noExtField oldMG- { mg_alts = noLoc- [ noLoc oldmatch- { m_pats = map mkParPat $ m_pats oldmatch- , m_ctxt = LambdaExpr+ needParens = any (patNeedsParens appPrec . unLoc) ((unLoc . m_pats) oldmatch)+ in [ suggest "Use lambda" (reLoc o)+ ( noLoc $ HsLam noAnn LamSingle oldMG+ { mg_alts = noLocA+ [ noLocA oldmatch+ { m_pats = L noSpanAnchor (map mkParPat $ (unLoc . m_pats) oldmatch)+ , m_ctxt = LamAlt LamSingle } ] }- :: LHsExpr GhcPs+ :: Located (HsExpr GhcPs) ) r ] -- otherwise we should use @LambdaCase@- MG _ (L _ _) _ ->- [(suggestN "Use lambda-case" o $ noLoc $ HsLamCase noExtField matchGroup)+ MG _ (L _ _) ->+ [(suggestN "Use lambda-case" (reLoc o) $ noLoc $ HsLam noAnn LamCase matchGroup) {ideaNote=[RequiresExtension "LambdaCase"]}] _ -> [] where -- | Filter out tuple arguments, converting the @x@ (matched in the lambda) variable argument -- to a missing argument, so that we get the proper section.- removeX :: LHsTupArg GhcPs -> LHsTupArg GhcPs- removeX (L _ (Present _ (view -> Var_ x')))- | x == x' = noLoc $ Missing noExtField+ removeX :: HsTupArg GhcPs -> HsTupArg GhcPs+ removeX (Present _ (view -> Var_ x'))+ | x == x' = Missing noAnn removeX y = y -- | Extract the name of an argument of a tuple if it's present and a variable.- tupArgVar :: LHsTupArg GhcPs -> Maybe String- tupArgVar (L _ (Present _ (view -> Var_ x))) = Just x+ tupArgVar :: HsTupArg GhcPs -> Maybe String+ tupArgVar (Present _ (view -> Var_ x)) = Just x tupArgVar _ = Nothing lambdaExp _ _ = []@@ -335,10 +347,7 @@ in (used, (True, p)) | otherwise = (mempty, (False, p)) - isWildPat :: LPat GhcPs -> Bool- isWildPat = \case (L _ (WildPat _)) -> True; _ -> False- -- Replace the pattern with a variable pattern if the pattern doesn't contain wildcards. munge :: String -> (Bool, LPat GhcPs) -> LPat GhcPs munge _ (True, p) = p- munge ident (False, L ploc _) = L ploc (VarPat noExtField (L ploc $ mkRdrUnqual $ mkVarOcc ident))+ munge ident (False, L ploc _) = L ploc (VarPat noExtField (noLocA $ mkRdrUnqual $ mkVarOcc ident))
src/Hint/List.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-} {- Find and match:@@ -34,6 +35,8 @@ foo = [x | False, x <- [1 .. 10]] -- [] foo = [_ | x <- _, let _ = A{x}] issue1039 = foo (map f [1 | _ <- []]) -- [f 1 | _ <- []]+{-# LANGUAGE OverloadedLists #-} \+issue114 = True:[] </TEST> -} @@ -41,18 +44,19 @@ import Control.Applicative import Data.Generics.Uniplate.DataOnly+import Data.List.NonEmpty qualified as NE import Data.List.Extra import Data.Maybe import Prelude -import Hint.Type(DeclHint,Idea,suggest,ignore,substVars,toRefactSrcSpan,toSS)+import Hint.Type(DeclHint,Idea,suggest,ignore,substVars,toRefactSrcSpan,toSSA,modComments,firstDeclComments) import Refact.Types hiding (SrcSpan)-import qualified Refact.Types as R+import Refact.Types qualified as R import GHC.Hs import GHC.Types.SrcLoc-import GHC.Types.Basic+import GHC.Types.SourceText import GHC.Types.Name.Reader import GHC.Data.FastString import GHC.Builtin.Types@@ -60,18 +64,25 @@ import GHC.Util import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr-import Language.Haskell.GhclibParserEx.GHC.Hs.Types+import Language.Haskell.GhclibParserEx.GHC.Hs.Type import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader listHint :: DeclHint-listHint _ _ = listDecl+listHint _ modu = listDecl overloadedListsOn+ where+ -- Comments appearing without a line-break before the first+ -- declaration in a module are now associated with the declaration+ -- not the module so to be safe, look also at `firstDeclComments+ -- modu` (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).+ exts = concatMap snd (languagePragmas (pragmas (modComments modu) ++ pragmas (firstDeclComments modu)))+ overloadedListsOn = "OverloadedLists" `elem` exts -listDecl :: LHsDecl GhcPs -> [Idea]-listDecl x =- concatMap (listExp False) (childrenBi x) +++listDecl :: Bool -> LHsDecl GhcPs -> [Idea]+listDecl overloadedListsOn x =+ concatMap (listExp overloadedListsOn False) (childrenBi x) ++ stringType x ++ concatMap listPat (childrenBi x) ++ concatMap listComp (universeBi x)@@ -84,7 +95,6 @@ listCompCheckGuards o ListComp stmts listComp o@(L _ (HsDo _ MonadComp (L _ stmts))) = listCompCheckGuards o MonadComp stmts- listComp (L _ HsPar{}) = [] -- App2 "sees through" paren, which causes duplicate hints with universeBi listComp o@(view -> App2 mp f (L _ (HsDo _ ListComp (L _ stmts)))) = listCompCheckMap o mp f ListComp stmts@@ -92,41 +102,42 @@ listCompCheckMap o mp f MonadComp stmts listComp _ = [] -listCompCheckGuards :: LHsExpr GhcPs -> HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> [Idea]+listCompCheckGuards :: LHsExpr GhcPs -> HsDoFlavour -> [ExprLStmt GhcPs] -> [Idea] listCompCheckGuards o ctx stmts =- let revs = reverse stmts- e@(L _ LastStmt{}) = head revs -- In a ListComp, this is always last.- xs = reverse (tail revs) in+ let revs = NE.reverse $ NE.fromList stmts+ e@(L _ LastStmt{}) = NE.head revs -- In a ListComp, this is always last.+ xs = reverse (NE.tail revs) in list_comp_aux e xs where list_comp_aux e xs- | "False" `elem` cons = [suggest "Short-circuited list comprehension" o o' (suggestExpr o o')]- | "True" `elem` cons = [suggest "Redundant True guards" o o2 (suggestExpr o o2)]- | not (astListEq xs ys) = [suggest "Move guards forward" o o3 (suggestExpr o o3)]+ | "False" `elem` cons = [suggest "Short-circuited list comprehension" (reLoc o) (reLoc o') (suggestExpr o o')]+ | "True" `elem` cons = [suggest "Redundant True guards" (reLoc o) (reLoc o2) (suggestExpr o o2)]+ | not (astListEq xs ys) = [suggest "Move guards forward" (reLoc o) (reLoc o3) (suggestExpr o o3)] | otherwise = [] where ys = moveGuardsForward xs- o' = noLoc $ ExplicitList noExtField Nothing []- o2 = noLoc $ HsDo noExtField ctx (noLoc (filter ((/= Just "True") . qualCon) xs ++ [e]))- o3 = noLoc $ HsDo noExtField ctx (noLoc $ ys ++ [e])+ o' = noLocA $ ExplicitList noAnn []+ o2 = noLocA $ HsDo noAnn ctx (noLocA (filter ((/= Just "True") . qualCon) xs ++ [e]))+ o3 = noLocA $ HsDo noAnn ctx (noLocA $ ys ++ [e]) cons = mapMaybe qualCon xs qualCon :: ExprLStmt GhcPs -> Maybe String qualCon (L _ (BodyStmt _ (L _ (HsVar _ (L _ x))) _ _)) = Just (occNameStr x) qualCon _ = Nothing listCompCheckMap ::- LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> [Idea]+ LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsDoFlavour -> [ExprLStmt GhcPs] -> [Idea] listCompCheckMap o mp f ctx stmts | varToStr mp == "map" =- [suggest "Move map inside list comprehension" o o2 (suggestExpr o o2)]+ [suggest "Move map inside list comprehension" (reLoc o) (reLoc o2) (suggestExpr o o2)] where- revs = reverse stmts- L _ (LastStmt _ body b s) = head revs -- In a ListComp, this is always last.- last = noLoc $ LastStmt noExtField (noLoc $ HsApp noExtField (paren f) (paren body)) b s- o2 =noLoc $ HsDo noExtField ctx (noLoc $ reverse (tail revs) ++ [last])+ revs = NE.reverse $ NE.fromList stmts+ L _ (LastStmt _ body b s) = NE.head revs -- In a ListComp, this is always last.+ last = noLocA $ LastStmt noExtField (noLocA $ HsApp noExtField (paren f) (paren body)) b s+ o2 =noLocA $ HsDo noAnn ctx (noLocA $ reverse (NE.tail revs) ++ [last])+ listCompCheckMap _ _ _ _ _ = [] suggestExpr :: LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring R.SrcSpan]-suggestExpr o o2 = [Replace Expr (toSS o) [] (unsafePrettyPrint o2)]+suggestExpr o o2 = [Replace Expr (toSSA o) [] (unsafePrettyPrint o2)] moveGuardsForward :: [ExprLStmt GhcPs] -> [ExprLStmt GhcPs] moveGuardsForward = reverse . f [] . reverse@@ -149,31 +160,34 @@ f guards (x@(L _ LetStmt{}):xs) = f (x:guards) xs f guards xs = reverse guards ++ xs -listExp :: Bool -> LHsExpr GhcPs -> [Idea]-listExp b (fromParen -> x) =- if null res then concatMap (listExp $ isAppend x) $ children x else [head res]+listExp :: Bool -> Bool -> LHsExpr GhcPs -> [Idea]+listExp overloadedListsOn b (fromParen -> x) =+ if null res+ then concatMap (listExp overloadedListsOn $ isAppend x) $ children x+ else [NE.head $ NE.fromList res] where- res = [suggest name x x2 [r]- | (name, f) <- checks+ res = [suggest name (reLoc x) (reLoc x2) [r]+ | (name, f) <- checks overloadedListsOn , Just (x2, subts, temp) <- [f b x]- , let r = Replace Expr (toSS x) subts temp ]+ , let r = Replace Expr (toSSA x) subts temp ] listPat :: LPat GhcPs -> [Idea]-listPat x = if null res then concatMap listPat $ children x else [head res]- where res = [suggest name x x2 [r]+listPat x = if null res then concatMap listPat $ children x else [NE.head $ NE.fromList res]+ where res = [suggest name (reLoc x) (reLoc x2) [r] | (name, f) <- pchecks , Just (x2, subts, temp) <- [f x]- , let r = Replace Pattern (toSS x) subts temp ]+ , let r = Replace Pattern (toSSA x) subts temp ]+ isAppend :: View a App2 => a -> Bool isAppend (view -> App2 op _ _) = varToStr op == "++" isAppend _ = False -checks ::[(String, Bool -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String))]-checks = let (*) = (,) in drop1 -- see #174+checks :: Bool -> [(String, Bool -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String))]+checks overloadedListsOn = let (*) = (,) in drop1 -- see #174 [ "Use string literal" * useString- , "Use list literal" * useList , "Use :" * useCons ]+ <> ["Use list literal" * useList | not overloadedListsOn ] -- see #114 pchecks :: [(String, LPat GhcPs -> Maybe (LPat GhcPs, [(String, R.SrcSpan)], String))] pchecks = let (*) = (,) in drop1 -- see #174@@ -183,16 +197,16 @@ usePString :: LPat GhcPs -> Maybe (LPat GhcPs, [a], String) usePString (L _ (ListPat _ xs)) | not $ null xs, Just s <- mapM fromPChar xs =- let literal = noLoc $ LitPat noExtField (HsString NoSourceText (fsLit (show s)))+ let literal = noLocA $ LitPat noExtField (HsString NoSourceText (fsLit (show s))) :: LPat GhcPs in Just (literal, [], unsafePrettyPrint literal) usePString _ = Nothing usePList :: LPat GhcPs -> Maybe (LPat GhcPs, [(String, R.SrcSpan)], String) usePList = fmap ( (\(e, s) ->- (noLoc (ListPat noExtField e)+ (noLocA (ListPat noAnn e) , map (fmap toRefactSrcSpan . fst) s- , unsafePrettyPrint (noLoc $ ListPat noExtField (map snd s) :: LPat GhcPs))+ , unsafePrettyPrint (noLocA $ ListPat noAnn (map snd s) :: LPat GhcPs)) ) . unzip )@@ -203,20 +217,20 @@ f first _ _ = Nothing g :: String -> LPat GhcPs -> ((String, SrcSpan), LPat GhcPs)- g s (getLoc -> loc) = ((s, loc), noLoc $ VarPat noExtField (noLoc $ mkVarUnqual (fsLit s)))+ g s (locA . getLoc -> loc) = ((s, loc), noLocA $ VarPat noExtField (noLocA $ mkVarUnqual (fsLit s))) useString :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [a], String)-useString b (L _ (ExplicitList _ _ xs)) | not $ null xs, Just s <- mapM fromChar xs =- let literal = noLoc (HsLit noExtField (HsString NoSourceText (fsLit (show s))))+useString b (L _ (ExplicitList _ xs)) | not $ null xs, Just s <- mapM fromChar xs =+ let literal = noLocA (HsLit noExtField (HsString NoSourceText (fsLit (show s)))) :: LHsExpr GhcPs in Just (literal, [], unsafePrettyPrint literal) useString _ _ = Nothing useList :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String) useList b = fmap ( (\(e, s) ->- (noLoc (ExplicitList noExtField Nothing e)- , map (fmap toSS) s- , unsafePrettyPrint (noLoc $ ExplicitList noExtField Nothing (map snd s) :: LHsExpr GhcPs))+ (noLocA (ExplicitList noAnn e)+ , map (fmap toSSA) s+ , unsafePrettyPrint (noLocA $ ExplicitList noAnn (map snd s) :: LHsExpr GhcPs)) ) . unzip )@@ -235,41 +249,41 @@ , Just (newX, tplX, spanX) <- f x , not $ isAppend y = Just (gen newX y- , [("x", spanX), ("xs", toSS y)]+ , [("x", spanX), ("xs", toSSA y)] , unsafePrettyPrint $ gen tplX (strToVar "xs") ) where f :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, LHsExpr GhcPs, R.SrcSpan)- f (L _ (ExplicitList _ _ [x]))- | isAtom x || isApp x = Just (x, strToVar "x", toSS x)- | otherwise = Just (addParen x, addParen (strToVar "x"), toSS x)+ f (L _ (ExplicitList _ [x]))+ | isAtom x || isApp x = Just (x, strToVar "x", toSSA x)+ | otherwise = Just (addParen x, addParen (strToVar "x"), toSSA x) f _ = Nothing gen :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs- gen x = noLoc . OpApp noExtField x (noLoc (HsVar noExtField (noLoc consDataCon_RDR)))+ gen x = noLocA . OpApp noExtField x (noLocA (HsVar noExtField (noLocA consDataCon_RDR))) useCons _ _ = Nothing typeListChar :: LHsType GhcPs typeListChar =- noLoc $ HsListTy noExtField- (noLoc (HsTyVar noExtField NotPromoted (noLoc (mkVarUnqual (fsLit "Char")))))+ noLocA $ HsListTy noAnn+ (noLocA (HsTyVar noAnn NotPromoted (noLocA (mkVarUnqual (fsLit "Char"))))) typeString :: LHsType GhcPs typeString =- noLoc $ HsTyVar noExtField NotPromoted (noLoc (mkVarUnqual (fsLit "String")))+ noLocA $ HsTyVar noAnn NotPromoted (noLocA (mkVarUnqual (fsLit "String"))) stringType :: LHsDecl GhcPs -> [Idea] stringType (L _ x) = case x of InstD _ ClsInstD{ cid_inst= ClsInstDecl{cid_binds=x, cid_tyfam_insts=y, cid_datafam_insts=z}} ->- f x ++ f y ++ f z -- Pretty much everthing but the instance type.+ f x ++ f y ++ f z -- Pretty much everything but the instance type. _ -> f x where f x = concatMap g $ childrenBi x g :: LHsType GhcPs -> [Idea]- g e@(fromTyParen -> x) = [ignore "Use String" x (transform f x)+ g e@(fromTyParen -> x) = [ignore "Use String" (reLoc x) (reLoc (transform f x)) rs | not . null $ rs] where f x = if astEq x typeListChar then typeString else x- rs = [Replace Type (toSS t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq t typeListChar]+ rs = [Replace Type (toSSA t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq t typeListChar]
src/Hint/ListRec.hs view
@@ -31,7 +31,7 @@ module Hint.ListRec(listRecHint) where -import Hint.Type (DeclHint, Severity(Suggestion, Warning), idea, toSS)+import Hint.Type (DeclHint, Severity(Suggestion, Warning), idea, toSSA) import Data.Generics.Uniplate.DataOnly import Data.List.Extra@@ -51,6 +51,9 @@ import GHC.Hs.Decls import GHC.Types.Basic +import GHC.Parser.Annotation+import Language.Haskell.Syntax.Extension+ import GHC.Util import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr@@ -69,7 +72,7 @@ guard $ recursiveStr `notElem` varss y -- Maybe we can do better here maintaining source -- formatting?- pure $ idea severity ("Use " ++ use) o y [Replace Decl (toSS o) [] (unsafePrettyPrint y)]+ pure $ idea severity ("Use " ++ use) (reLoc o) (reLoc y) [Replace Decl (toSSA o) [] (unsafePrettyPrint y)] recursiveStr :: String recursiveStr = "_recursive_"@@ -93,7 +96,6 @@ Int -- list position BList (LHsExpr GhcPs) -- list type/body - --------------------------------------------------------------------- -- MATCH THE RECURSION @@ -132,19 +134,19 @@ asDo :: LHsExpr GhcPs -> [LStmt GhcPs (LHsExpr GhcPs)] asDo (view -> App2 bind lhs- (L _ (HsLam _ MG {- mg_origin=FromSource+ (L _ (HsLam _ LamSingle MG {+ mg_ext=FromSource , mg_alts=L _ [- L _ Match { m_ctxt=LambdaExpr- , m_pats=[v@(L _ VarPat{})]+ L _ Match { m_ctxt=(LamAlt LamSingle)+ , m_pats=L _ [v@(L _ VarPat{})] , m_grhss=GRHSs _ [L _ (GRHS _ [] rhs)]- (L _ (EmptyLocalBinds _))}]}))+ (EmptyLocalBinds _)}]})) ) =- [ noLoc $ BindStmt noExtField v lhs- , noLoc $ BodyStmt noExtField rhs noSyntaxExpr noSyntaxExpr ]+ [ noLocA $ BindStmt noAnn v lhs+ , noLocA $ BodyStmt noExtField rhs noSyntaxExpr noSyntaxExpr ] asDo (L _ (HsDo _ (DoExpr _) (L _ stmts))) = stmts-asDo x = [noLoc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr]+asDo x = [noLocA $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr] ---------------------------------------------------------------------@@ -155,7 +157,7 @@ findCase x = do -- Match a function binding with two alternatives. (L _ (ValD _ FunBind {fun_matches=- MG{mg_origin=FromSource, mg_alts=+ MG{mg_ext=FromSource, mg_alts= (L _ [ x1@(L _ Match{..}) -- Match fields. , x2]), ..} -- Match group fields.@@ -170,14 +172,14 @@ (ps, b2) <- pure $ eliminateArgs ps1 b2 let ps12 = let (a, b) = splitAt p1 ps1 in map strToPat (a ++ xs : b) -- Function arguments.- emptyLocalBinds = noLoc $ EmptyLocalBinds noExtField -- Empty where clause.- gRHS e = noLoc $ GRHS noExtField [] e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs.- gRHSSs e = GRHSs noExtField [gRHS e] emptyLocalBinds -- Guarded rhs set.- match e = Match{m_ext=noExtField,m_pats=ps12, m_grhss=gRHSSs e, ..} -- Match.- matchGroup e = MG{mg_alts=noLoc [noLoc $ match e], mg_origin=Generated, ..} -- Match group.+ emptyLocalBinds = EmptyLocalBinds noExtField :: HsLocalBindsLR GhcPs GhcPs -- Empty where clause.+ gRHS e = noLocA $ GRHS noAnn [] e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs.+ gRHSSs e = GRHSs emptyComments [gRHS e] emptyLocalBinds -- Guarded rhs set.+ match e = Match{m_ext=noExtField,m_pats=noLocA ps12, m_grhss=gRHSSs e, ..} -- Match.+ matchGroup e = MG{mg_alts=noLocA [noLocA $ match e], mg_ext=Generated OtherExpansion SkipPmc, ..} -- Match group. funBind e = FunBind {fun_matches=matchGroup e, ..} :: HsBindLR GhcPs GhcPs -- Fun bind. - pure (ListCase ps b1 (x, xs, b2), noLoc . ValD noExtField . funBind)+ pure (ListCase ps b1 (x, xs, b2), noLocA . ValD noExtField . funBind) delCons :: String -> Int -> String -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs) delCons func pos var (fromApps -> (view -> Var_ x) : xs) | func == x = do@@ -207,10 +209,10 @@ , m_pats = ps , m_grhss = GRHSs {grhssGRHSs=[L l (GRHS _ [] body)]- , grhssLocalBinds=L _ (EmptyLocalBinds _)+ , grhssLocalBinds=EmptyLocalBinds _ } } <- pure x- (a, b, c) <- findPat ps+ (a, b, c) <- findPat (unLoc ps) pure $ Branch (occNameStr name) a b c $ simplifyExp body findPat :: [LPat GhcPs] -> Maybe ([String], Int, BList)@@ -225,6 +227,6 @@ readPat (view -> PVar_ x) = Just $ Left x readPat (L _ (ParPat _ (L _ (ConPat _ (L _ n) (InfixCon (view -> PVar_ x) (view -> PVar_ xs)))))) | n == consDataCon_RDR = Just $ Right $ BCons x xs-readPat (L _ (ConPat _ (L _ n) (PrefixCon [])))+readPat (L _ (ConPat _ (L _ n) (PrefixCon [] []))) | n == nameRdrName nilDataConName = Just $ Right BNil readPat _ = Nothing
src/Hint/Match.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-} {-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts #-} @@ -39,15 +40,12 @@ module Hint.Match(readMatch) where -import Hint.Type (ModuleEx,Idea,idea,ideaNote,toSS)---- import Language.Haskell.GhclibParserEx.Dump--- import GHC.Utils.Outputable+import Hint.Type (ModuleEx,Idea,idea,ideaNote,toSSA) import Util import Timing-import qualified Data.Set as Set-import qualified Refact.Types as R+import Data.Set qualified as Set+import Refact.Types qualified as R import Control.Monad import Data.Tuple.Extra@@ -55,10 +53,9 @@ import Config.Type import Data.Generics.Uniplate.DataOnly -import GHC.Data.Bag import GHC.Hs import GHC.Types.SrcLoc-import GHC.Types.Basic+import GHC.Types.SourceText import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence import Data.Data@@ -67,7 +64,6 @@ import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader--- import Debug.Trace readMatch :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea] readMatch settings = findIdeas (concatMap readRule settings)@@ -114,17 +110,17 @@ findIdeas :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea] findIdeas matches s _ decl = timed "Hint" "Match apply" $ forceList- [ (idea (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes}+ [ (idea (hintRuleSeverity m) (hintRuleName m) (reLoc x) (reLoc y) [r]){ideaNote=notes} | (name, expr) <- findDecls decl , (parent,x) <- universeParentExp expr , m <- matches, Just (y, tpl, notes, subst) <- [matchIdea s name m parent x]- , let r = R.Replace R.Expr (toSS x) subst (unsafePrettyPrint tpl)+ , let r = R.Replace R.Expr (toSSA x) subst (unsafePrettyPrint tpl) ] -- | A list of root expressions, with their associated names findDecls :: LHsDecl GhcPs -> [(String, LHsExpr GhcPs)] findDecls x@(L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =- [(fromMaybe "" $ bindName xs, x) | xs <- bagToList cid_binds, x <- childrenBi xs]+ [(fromMaybe "" $ bindName xs, x) | xs <- cid_binds, x <- childrenBi xs] findDecls (L _ RuleD{}) = [] -- Often rules contain things that HLint would rewrite. findDecls x = map (fromMaybe "" $ declName x,) $ childrenBi x @@ -139,14 +135,15 @@ rhs = unextendInstances hintRuleRHS sa = hintRuleScope nm a b = scopeMatch (sa, a) (sb, b)+ (u, extra) <- unifyExp nm True lhs x u <- validSubst astEq u -- Need to check free vars before unqualification, but after subst -- (with 'e') need to unqualify before substitution (with 'res').- let rhs' | Just fun <- extra = rebracket1 $ noLoc (HsApp noExtField fun rhs)+ let rhs' | Just fun <- extra = rebracket1 $ noLocA (HsApp noExtField fun rhs) | otherwise = rhs- (e, tpl) = substitute u rhs'+ (e, (tpl, substNoParens)) = substitute u rhs' noParens = [varToStr $ fromParen x | L _ (HsApp _ (varToStr -> "_noParen_") x) <- universe tpl] u <- pure (removeParens noParens u)@@ -159,15 +156,19 @@ -- we have lambdas we might be moving, and QuasiQuotes, we might -- inadvertantly break free vars because quasi quotes don't show -- what free vars they make use of.- guard $ not (any isLambda $ universe lhs) || not (any isQuasiQuote $ universe x)+ guard $ not (any isLambda $ universe lhs) || not (any isQuasiQuoteExpr $ universe x) guard $ checkSide (unextendInstances <$> hintRuleSide) $ ("original", x) : ("result", res) : fromSubst u guard $ checkDefine declName parent rhs - (u, tpl) <- pure $ if any ((== noSrcSpan) . getLoc . snd) (fromSubst u) then (mempty, res) else (u, tpl)- tpl <- pure $ unqualify sa sb (performSpecial tpl)+ (u, tpl) <- pure $ if any ((== noSrcSpan) . locA . getLoc . snd) (fromSubst u) then (mempty, res) else (u, tpl)+ tpl <- pure $ unqualify sa sb (addBracket parent $ performSpecial tpl) - pure (res, tpl, hintRuleNotes, [(s, toSS pos) | (s, pos) <- fromSubst u, getLoc pos /= noSrcSpan])+ pure ( res, tpl, hintRuleNotes,+ [ (s, toSSA pos') | (s, pos) <- fromSubst u, locA (getLoc pos) /= noSrcSpan+ , let pos' = if s `elem` substNoParens then fromParen pos else pos+ ]+ ) --------------------------------------------------------------------- -- SIDE CONDITIONS@@ -199,13 +200,13 @@ isType "Compare" x = True -- Just a hint for proof stuff isType "Atom" x = isAtom x isType "WHNF" x = isWHNF x- isType "Wildcard" x = any isFieldPun (universeBi x) || any hasFieldsDotDot (universeBi x)+ isType "Wildcard" x = any hasFieldsDotDot (universeBi x) isType "Nat" (asInt -> Just x) | x >= 0 = True isType "Pos" (asInt -> Just x) | x > 0 = True isType "Neg" (asInt -> Just x) | x < 0 = True isType "NegZero" (asInt -> Just x) | x <= 0 = True isType "LitInt" (L _ (HsLit _ HsInt{})) = True- isType "LitInt" (L _ (HsOverLit _ (OverLit _ HsIntegral{} _))) = True+ isType "LitInt" (L _ (HsOverLit _ (OverLit _ HsIntegral{}))) = True isType "LitString" (L _ (HsLit _ HsString{})) = True isType "Var" (L _ HsVar{}) = True isType "App" (L _ HsApp{}) = True@@ -221,11 +222,11 @@ asInt (L _ (HsPar _ x)) = asInt x asInt (L _ (NegApp _ x _)) = negate <$> asInt x asInt (L _ (HsLit _ (HsInt _ (IL _ _ x)) )) = Just x- asInt (L _ (HsOverLit _ (OverLit _ (HsIntegral (IL _ _ x)) _))) = Just x+ asInt (L _ (HsOverLit _ (OverLit _ (HsIntegral (IL _ _ x))))) = Just x asInt _ = Nothing list :: LHsExpr GhcPs -> [LHsExpr GhcPs]- list (L _ (ExplicitList _ _ xs)) = xs+ list (L _ (ExplicitList _ xs)) = xs list x = [x] sub :: LHsExpr GhcPs -> LHsExpr GhcPs@@ -236,10 +237,10 @@ -- Does the result look very much like the declaration? checkDefine :: String -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool checkDefine declName Nothing y =- let funOrOp expr = case expr of+ let funOrOp expr = (case expr of L _ (HsApp _ fun _) -> funOrOp fun L _ (OpApp _ _ op _) -> funOrOp op- other -> other+ other -> other) :: LHsExpr GhcPs in declName /= varToStr (transformBi unqual $ funOrOp y) checkDefine _ _ _ = True @@ -258,12 +259,12 @@ unqualify :: Scope -> Scope -> LHsExpr GhcPs -> LHsExpr GhcPs unqualify from to = transformBi f where- f :: Located RdrName -> Located RdrName+ f :: LocatedN RdrName -> LocatedN RdrName f x@(L _ (Unqual s)) | isUnifyVar (occNameString s) = x f x = scopeMove (from, x) to addBracket :: Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs-addBracket (Just (i, p)) c | needBracketOld i p c = noLoc $ HsPar noExtField c+addBracket (Just (i, p)) c | needBracketOld i p c = nlHsPar c addBracket _ x = x -- Type substitution e.g. 'Foo Int' for 'a' in 'Proxy a' can lead to a@@ -274,5 +275,5 @@ where f :: LHsType GhcPs -> LHsType GhcPs f (L _ (HsAppTy _ t x@(L _ HsAppTy{}))) =- noLoc (HsAppTy noExtField t (noLoc (HsParTy noExtField x)))+ noLocA (HsAppTy noExtField t (noLocA (HsParTy noAnn x))) f x = x
src/Hint/Monad.hs view
@@ -1,4 +1,11 @@-{-# LANGUAGE LambdaCase, ViewPatterns, PatternGuards, FlexibleContexts #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+ {- Find and match: @@ -45,7 +52,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@@ -63,11 +72,13 @@ import Hint.Type import GHC.Hs hiding (Warning)+import GHC.Types.Fixity import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence-import GHC.Data.Bag+import GHC.Data.Strict qualified+ import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable@@ -79,7 +90,7 @@ import Data.Maybe import Data.List.Extra import Refact.Types hiding (Match)-import qualified Refact.Types as R+import Refact.Types qualified as R badFuncs :: [String]@@ -112,26 +123,45 @@ (L l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (L l . OpApp noExtField op dol) x (L loc (HsDo _ ctx (L loc2 [L loc3 (BodyStmt _ y _ _ )]))) -> let doOrMDo = case ctx of MDoExpr _ -> "mdo"; _ -> "do"- in [ ideaRemove Ignore ("Redundant " ++ doOrMDo) (doSpan doOrMDo loc) doOrMDo [Replace Expr (toSS x) [("y", toSS y)] "y"]+ in [ ideaRemove Ignore ("Redundant " ++ doOrMDo) (doSpan doOrMDo (locA loc)) doOrMDo [Replace Expr (toSSA x) [("y", toSSA y)] "y"] | not $ doAsBrackets parentExpr y , not $ doAsAvoidingIndentation parentDo x ] (L loc (HsDo _ (DoExpr mm) (L _ xs))) ->- monadSteps (L loc . HsDo noExtField (DoExpr mm) . noLoc) xs ++- [suggest "Use let" from to [r] | (from, to, r) <- monadLet xs] +++ monadSteps (L loc . HsDo noAnn (DoExpr mm) . noLocA) xs +++ [suggest "Use let" (reLoc from) (reLoc to) [r] | (from, to, r) <- monadLet xs] ++ concat [f x | (L _ (BodyStmt _ x _ _)) <- dropEnd1 xs] ++ concat [f x | (L _ (BindStmt _ (L _ WildPat{}) x)) <- dropEnd1 xs] _ -> [] where f = monadNoResult (fromMaybe "" decl) id- seenVoid wrap x = monadNoResult (fromMaybe "" decl) wrap x- ++ [warn "Redundant void" (wrap x) x [Replace Expr (toSS (wrap x)) [("a", toSS x)] "a"] | returnsUnit x]+ seenVoid wrap (L l (HsPar x y)) = seenVoid (wrap . L l . \y -> HsPar x y) 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 _ -> let start = realSrcSpanStart s end = mkRealSrcLoc (srcSpanFile s) (srcLocLine start) (srcLocCol start + length doOrMDo)- in RealSrcSpan (mkRealSrcSpan start end) Nothing+ in RealSrcSpan (mkRealSrcSpan start end) GHC.Data.Strict.Nothing -- Sometimes people write 'a * do a + b', to avoid brackets, -- or using BlockArguments they can write 'a do a b',@@ -143,26 +173,38 @@ doAsBrackets Nothing x = False --- Sometimes people write do, to avoid identation, see+-- Sometimes people write do, to avoid indentation, see -- https://github.com/ndmitchell/hlint/issues/978--- Return True if they are using do as avoiding identation+-- Return True if they are using do as avoiding indentation doAsAvoidingIndentation :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool-doAsAvoidingIndentation (Just (L _ (HsDo _ _ (L (RealSrcSpan a _) _)))) (L _ (HsDo _ _ (L (RealSrcSpan b _) _)))- = srcSpanStartCol a == srcSpanStartCol b+doAsAvoidingIndentation (Just (L _ (HsDo _ _ (L anna _)))) (L _ (HsDo _ _ (L annb _)))+ | EpAnn (EpaSpan (RealSrcSpan a _)) _ _ <- anna+ , EpAnn (EpaSpan (RealSrcSpan b _)) _ _ <- annb+ = 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 . \y -> HsPar noAnn y) x+ go wrap (L l (HsApp _ x y)) = go (\x -> wrap $ L l (HsApp noExtField x y)) x+ go wrap (L l (OpApp _ x op y)) | isDol op = go (\x -> wrap $ L l (OpApp noExtField 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. monadNoResult :: String -> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]-monadNoResult inside wrap (L l (HsPar _ x)) = monadNoResult inside (wrap . L l . HsPar noExtField) x+monadNoResult inside wrap (L l (HsPar _ x)) = monadNoResult inside (wrap . nlHsPar) x monadNoResult inside wrap (L l (HsApp _ x y)) = monadNoResult inside (\x -> wrap $ L l (HsApp noExtField x y)) x monadNoResult inside wrap (L l (OpApp _ x tag@(L _ (HsVar _ (L _ op))) y)) | isDol tag = monadNoResult inside (\x -> wrap $ L l (OpApp noExtField x tag y)) x@@ -170,8 +212,7 @@ monadNoResult inside wrap x | x2 : _ <- filter (`isTag` x) badFuncs , let x3 = x2 ++ "_"-- = [warn ("Use " ++ x3) (wrap x) (wrap $ strToVar x3) [Replace Expr (toSS x) [] x3] | inside /= x3]+ = [warn ("Use " ++ x3) (reLoc (wrap x)) (reLoc (wrap $ strToVar x3)) [Replace Expr (toSSA x) [] x3] | inside /= x3] monadNoResult inside wrap (replaceBranches -> (bs, rewrap)) = map (\x -> x{ideaNote=nubOrd $ Note "May require adding void to other branches" : ideaNote x}) $ concat [monadNoResult inside id b | b <- bs]@@ -181,37 +222,37 @@ -- Rewrite 'do return x; $2' as 'do $2'. monadStep wrap (o@(L _ (BodyStmt _ (fromRet -> Just (ret, _)) _ _ )) : xs@(_:_))- = [ideaRemove Warning ("Redundant " ++ ret) (getLoc o) (unsafePrettyPrint o) [Delete Stmt (toSS o)]]+ = [ideaRemove Warning ("Redundant " ++ ret) (locA (getLoc o)) (unsafePrettyPrint o) [Delete Stmt (toSSA o)]] -- Rewrite 'do a <- $1; return a' as 'do $1'. monadStep wrap o@[ g@(L _ (BindStmt _ (L _ (VarPat _ (L _ p))) x)) , q@(L _ (BodyStmt _ (fromRet -> Just (ret, L _ (HsVar _ (L _ v)))) _ _))] | occNameStr p == occNameStr v- = [warn ("Redundant " ++ ret) (wrap o) (wrap [noLoc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr])- [Replace Stmt (toSS g) [("x", toSS x)] "x", Delete Stmt (toSS q)]]+ = [warn ("Redundant " ++ ret) (reLoc (wrap o)) (reLoc (wrap [noLocA $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr]))+ [Replace Stmt (toSSA g) [("x", toSSA x)] "x", Delete Stmt (toSSA q)]] -- Suggest to use join. Rewrite 'do x <- $1; x; $2' as 'do join $1; $2'. monadStep wrap o@(g@(L _ (BindStmt _ (view -> PVar_ p) x)):q@(L _ (BodyStmt _ (view -> Var_ v) _ _)):xs) | p == v && v `notElem` varss xs- = let app = noLoc $ HsApp noExtField (strToVar "join") x- body = noLoc $ BodyStmt noExtField (rebracket1 app) noSyntaxExpr noSyntaxExpr+ = let app = noLocA $ HsApp noExtField (strToVar "join") x+ body = noLocA $ BodyStmt noExtField (rebracket1 app) noSyntaxExpr noSyntaxExpr stmts = body : xs- in [warn "Use join" (wrap o) (wrap stmts) r]- where r = [Replace Stmt (toSS g) [("x", toSS x)] "join x", Delete Stmt (toSS q)]+ in [warn "Use join" (reLoc (wrap o)) (reLoc (wrap stmts)) r]+ where r = [Replace Stmt (toSSA g) [("x", toSSA x)] "join x", Delete Stmt (toSSA q)] -- Redundant variable capture. Rewrite 'do _ <- <return ()>; $1' as -- 'do <return ()>; $1'. monadStep wrap (o@(L loc (BindStmt _ p x)) : rest) | isPWildcard p, returnsUnit x = let body = L loc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr :: ExprLStmt GhcPs- in [warn "Redundant variable capture" o body [Replace Stmt (toSS o) [("x", toSS x)] "x"]]+ in [warn "Redundant variable capture" (reLoc o) (reLoc body) [Replace Stmt (toSSA o) [("x", toSSA x)] "x"]] -- Redundant unit return : 'do <return ()>; return ()'. monadStep wrap o@[ L _ (BodyStmt _ x _ _) , q@(L _ (BodyStmt _ (fromRet -> Just (ret, L _ (HsVar _ (L _ unit)))) _ _))] | returnsUnit x, occNameStr unit == "()"- = [warn ("Redundant " ++ ret) (wrap o) (wrap $ take 1 o) [Delete Stmt (toSS q)]]+ = [warn ("Redundant " ++ ret) (reLoc (wrap o)) (reLoc (wrap $ take 1 o)) [Delete Stmt (toSSA q)]] -- Rewrite 'do x <- $1; return $ f $ g x' as 'f . g <$> x' monadStep wrap@@ -219,8 +260,8 @@ , q@(L _ (BodyStmt _ (fromApplies -> (ret:f:fs, view -> Var_ v)) _ _))] | isReturn ret, notDol x, u == v, length fs < 3, all isSimple (f : fs), v `notElem` vars (f : fs) =- [warn "Use <$>" (wrap o) (wrap [noLoc $ BodyStmt noExtField (noLoc $ OpApp noExtField (foldl' (\acc e -> noLoc $ OpApp noExtField acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr])- [Replace Stmt (toSS g) (("x", toSS x):zip vs (toSS <$> f:fs)) (intercalate " . " (take (length fs + 1) vs) ++ " <$> x"), Delete Stmt (toSS q)]]+ [warn "Use <$>" (reLoc (wrap o)) (reLoc (wrap [noLocA $ BodyStmt noExtField (noLocA $ OpApp noExtField (foldl' (\acc e -> noLocA $ OpApp noExtField acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr]))+ [Replace Stmt (toSSA g) (("x", toSSA x):zip vs (toSSA <$> f:fs)) (intercalate " . " (take (length fs + 1) vs) ++ " <$> x"), Delete Stmt (toSSA q)]] where isSimple (fromApps -> xs) = all isAtom (x : xs) vs = ('f':) . show <$> [0..]@@ -228,7 +269,6 @@ notDol :: LHsExpr GhcPs -> Bool notDol (L _ (OpApp _ _ op _)) = not $ isDol op notDol _ = True- monadStep _ _ = [] -- Suggest removing a return@@ -247,21 +287,21 @@ | p `notElem` vars y, p `notElem` delete p vs = Just (x, template p y, refact) where- refact = Replace Stmt (toSS x) [("lhs", toSS v), ("rhs", toSS y)]+ refact = Replace Stmt (toSSA x) [("lhs", toSSA v), ("rhs", toSSA y)] (unsafePrettyPrint $ template "lhs" (strToVar "rhs")) mkLet _ = Nothing template :: String -> LHsExpr GhcPs -> ExprLStmt GhcPs template lhs rhs =- let p = noLoc $ mkRdrUnqual (mkVarOcc lhs)- grhs = noLoc (GRHS noExtField [] rhs)- grhss = GRHSs noExtField [grhs] (noLoc (EmptyLocalBinds noExtField))- match = noLoc $ Match noExtField (FunRhs p Prefix NoSrcStrict) [] grhss- fb = noLoc $ FunBind noExtField p (MG noExtField (noLoc [match]) Generated) []- binds = unitBag fb- valBinds = ValBinds noExtField binds []- localBinds = noLoc $ HsValBinds noExtField valBinds- in noLoc $ LetStmt noExtField localBinds+ let p = noLocA $ mkRdrUnqual (mkVarOcc lhs)+ grhs = noLocA (GRHS noAnn [] rhs)+ grhss = GRHSs emptyComments [grhs] (EmptyLocalBinds noExtField)+ match = noLocA $ Match noExtField (FunRhs p Prefix NoSrcStrict noAnn) (noLocA []) grhss+ fb = noLocA $ FunBind noExtField p (MG (Generated OtherExpansion SkipPmc) (noLocA [match]))+ binds = [fb]+ valBinds = ValBinds NoAnnSortKey binds []+ localBinds = HsValBinds noAnn valBinds+ in noLocA $ LetStmt noAnn localBinds fromApplies :: LHsExpr GhcPs -> ([LHsExpr GhcPs], LHsExpr GhcPs) fromApplies (L _ (HsApp _ f x)) = first (f:) $ fromApplies (fromParen x)@@ -270,6 +310,6 @@ fromRet :: LHsExpr GhcPs -> Maybe (String, LHsExpr GhcPs) fromRet (L _ (HsPar _ x)) = fromRet x-fromRet (L _ (OpApp _ x (L _ (HsVar _ (L _ y))) z)) | occNameStr y == "$" = fromRet $ noLoc (HsApp noExtField x z)+fromRet (L _ (OpApp _ x (L _ (HsVar _ (L _ y))) z)) | occNameStr y == "$" = fromRet $ noLocA (HsApp noExtField x z) fromRet (L _ (HsApp _ x y)) | isReturn x = Just (unsafePrettyPrint x, y) fromRet _ = Nothing
src/Hint/Naming.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-@@ -44,12 +45,14 @@ import Hint.Type (Idea,DeclHint,suggest,ghcModule) import Data.Generics.Uniplate.DataOnly import Data.List.Extra (nubOrd, isPrefixOf)+import Data.List.NonEmpty (toList) import Data.Data import Data.Char import Data.Maybe-import qualified Data.Set as Set+import Data.Set qualified as Set import GHC.Types.Basic+import GHC.Types.SourceText import GHC.Data.FastString import GHC.Hs.Decls import GHC.Hs.Extension@@ -67,8 +70,8 @@ naming :: Set.Set String -> LHsDecl GhcPs -> [Idea] naming seen originalDecl = [ suggest "Use camelCase"- (shorten originalDecl)- (shorten replacedDecl)+ (reLoc (shorten originalDecl))+ (reLoc (shorten replacedDecl)) [ -- https://github.com/mpickering/apply-refact/issues/39 ] | not $ null suggestedNames@@ -84,9 +87,9 @@ replacedDecl = replaceNames suggestedNames originalDecl shorten :: LHsDecl GhcPs -> LHsDecl GhcPs-shorten (L locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG _ (L locMatches matches) FromSource) _))) =+shorten (L locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG FromSource (L locMatches matches))))) = L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ map shortenMatch matches}})-shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ grhss@(GRHSs _ rhss _) _))) =+shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ _ grhss@(GRHSs _ rhss _)))) = L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = map shortenLGRHS rhss}}) shorten x = x @@ -99,19 +102,23 @@ L locGRHS (GRHS ttg0 guards (L locExpr dots)) where dots :: HsExpr GhcPs- dots = HsLit noExtField (HsString (SourceText "...") (mkFastString "..."))+ dots = HsLit noExtField (HsString (SourceText (fsLit "...")) (fsLit "...")) getNames :: LHsDecl GhcPs -> [String] getNames decl = maybeToList (declName decl) ++ getConstructorNames (unLoc decl) getConstructorNames :: HsDecl GhcPs -> [String]-getConstructorNames (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ _ cons _))) =- concatMap (map unsafePrettyPrint . getConNames' . unLoc) cons- where- getConNames' ConDeclH98 {con_name = name} = [name]- getConNames' ConDeclGADT {con_names = names} = names+getConstructorNames tycld = case tycld of+ (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ (NewTypeCon con) _))) -> conNames [con]+ (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ (DataTypeCons _ cons) _))) -> conNames cons+ _ -> []+ where+ conNames :: [LConDecl GhcPs] -> [String]+ conNames = concatMap (map unsafePrettyPrint . conNamesInDecl . unLoc) -getConstructorNames _ = []+ conNamesInDecl :: ConDecl GhcPs -> [LIdP GhcPs]+ conNamesInDecl ConDeclH98 {con_name = name} = [name]+ conNamesInDecl ConDeclGADT {con_names = names} = Data.List.NonEmpty.toList names isSym :: String -> Bool isSym (x:_) = not $ isAlpha x || x `elem` "_'"@@ -120,10 +127,10 @@ 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 '#' $ filter (/= '\'') $ reverse $ drp '_' original+ good = all isAlphaNum $ drp '_' $ drp '#' $ reverse $ filter (/= '\'') $ drp '_' original drp x = dropWhile (== x) f xs = us ++ g ys
+ src/Hint/Negation.hs view
@@ -0,0 +1,62 @@+{-++Raise a warning if negation precedence may appear ambiguous to human readers.++<TEST>+yes = -1 ^ 2 -- @Suggestion -(1 ^ 2)+yes = -x ^ y -- @Suggestion -(x ^ y)+yes = -5 `plus` 3 -- @Suggestion -(5 `plus` 3)+yes = -f x `mod` y -- @Suggestion -(f x `mod` y)+yes = -x `mod` y -- @Suggestion -(x `mod` y)+no = -(5 + 3)+no = -5 + 3+no = -(f x)+no = -x+</TEST>+-}++module Hint.Negation(negationParensHint) where++import Hint.Type(DeclHint,Idea(..),rawIdea,toSSA)+import Config.Type+import Data.Generics.Uniplate.DataOnly+import Refact.Types+import GHC.Hs+import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import GHC.Types.SrcLoc++-- | See [motivating issue #1484](https://github.com/ndmitchell/hlint/issues/1484).+--+-- == Implementation note+--+-- The original intention was to compare fixities so as+-- to only fire the rule when the operand of prefix negation+-- has higher fixity than the negation itself (fixity 6).+--+-- However, since there do not exist any numerically-valued+-- operators with lower fixity than 6+-- (see [table](https://www.haskell.org/onlinereport/decls.html#sect4.4.2)),+-- we do not have to worry about fixity comparisons.+negationParensHint :: DeclHint+negationParensHint _ _ x =+ concatMap negatedOp (universeBi x :: [LHsExpr GhcPs])++negatedOp :: LHsExpr GhcPs -> [Idea]+negatedOp e =+ case e of+ L b1 (NegApp a1 inner@(L _ OpApp {}) a2) ->+ pure $+ rawIdea+ Suggestion+ "Parenthesize unary negation"+ (locA (getLoc e))+ (unsafePrettyPrint e)+ (Just renderedNewExpr)+ []+ [Replace (findType e) (toSSA e) [] renderedNewExpr]+ where+ renderedNewExpr = unsafePrettyPrint newExpr+ parenthesizedOperand = addParen inner+ newExpr = L b1 $ NegApp a1 parenthesizedOperand a2+ _ -> []
src/Hint/NewType.hs view
@@ -12,12 +12,12 @@ data Foo = Foo { field1, field2 :: Int} data S a = forall b . Show b => S b {-# LANGUAGE RankNTypes #-}; data S a = forall b . Show b => S b-{-# LANGUAGE RankNTypes #-}; data Foo = Foo (forall a. a) -- newtype Foo = Foo (forall a. a)+{-# LANGUAGE RankNTypes #-}; data Foo = Foo (forall a . a) -- newtype Foo = Foo (forall a. a) data Color a = Red a | Green a | Blue a data Pair a b = Pair a b data Foo = Bar data Foo a = Eq a => MkFoo a-data Foo a = () => Foo a -- newtype Foo a = Foo a+data Foo a = () => Foo a -- newtype Foo a = () => Foo a data X = Y {-# UNPACK #-} !Int -- newtype X = Y Int data A = A {b :: !C} -- newtype A = A {b :: C} data A = A Int#@@ -56,15 +56,15 @@ newtypeHintDecl :: LHsDecl GhcPs -> [Idea] newtypeHintDecl old | Just WarnNewtype{newDecl, insideType} <- singleSimpleField old- = [(suggestN "Use newtype instead of data" old newDecl)+ = [(suggestN "Use newtype instead of data" (reLoc old) (reLoc newDecl)) {ideaNote = [DecreasesLaziness | warnBang insideType]}] newtypeHintDecl _ = [] newTypeDerivingStrategiesHintDecl :: LHsDecl GhcPs -> [Idea] newTypeDerivingStrategiesHintDecl decl@(L _ (TyClD _ (DataDecl _ _ _ _ dataDef))) =- [ignoreNoSuggestion "Use DerivingStrategies" decl | shouldSuggestStrategies dataDef]-newTypeDerivingStrategiesHintDecl decl@(L _ (InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB _ (FamEqn _ _ _ _ _ dataDef)))))) =- [ignoreNoSuggestion "Use DerivingStrategies" decl | shouldSuggestStrategies dataDef]+ [ignoreNoSuggestion "Use DerivingStrategies" (reLoc decl) | shouldSuggestStrategies dataDef]+newTypeDerivingStrategiesHintDecl decl@(L _ (InstD _ (DataFamInstD _ (DataFamInstDecl ((FamEqn _ _ _ _ _ dataDef)))))) =+ [ignoreNoSuggestion "Use DerivingStrategies" (reLoc decl) | shouldSuggestStrategies dataDef] newTypeDerivingStrategiesHintDecl _ = [] -- | Determine if the given data definition should use deriving strategies.@@ -72,12 +72,11 @@ shouldSuggestStrategies dataDef = not (isData dataDef) && not (hasAllStrategies dataDef) hasAllStrategies :: HsDataDefn GhcPs -> Bool-hasAllStrategies (HsDataDefn _ NewType _ _ _ _ (L _ xs)) = all hasStrategyClause xs-hasAllStrategies _ = False+hasAllStrategies (HsDataDefn _ _ _ _ _ xs) = all hasStrategyClause xs isData :: HsDataDefn GhcPs -> Bool-isData (HsDataDefn _ NewType _ _ _ _ _) = False-isData (HsDataDefn _ DataType _ _ _ _ _) = True+isData (HsDataDefn _ _ _ _ (NewTypeCon _) _) = False+isData (HsDataDefn _ _ _ _ (DataTypeCons _ _) _) = True hasStrategyClause :: LHsDerivingClause GhcPs -> Bool hasStrategyClause (L _ (HsDerivingClause _ (Just _) _)) = True@@ -98,37 +97,45 @@ singleSimpleField :: LHsDecl GhcPs -> Maybe WarnNewtype singleSimpleField (L loc (TyClD ext decl@(DataDecl _ _ _ _ dataDef))) | Just inType <- simpleHsDataDefn dataDef =- Just WarnNewtype+ case dropBangs dataDef of+ DataTypeCons False [con] ->+ Just WarnNewtype { newDecl = L loc $ TyClD ext decl {tcdDataDefn = dataDef- { dd_ND = NewType- , dd_cons = dropBangs dataDef- }}+ { dd_cons = NewTypeCon con }} , insideType = inType }-singleSimpleField (L loc (InstD ext (DataFamInstD instExt (DataFamInstDecl (HsIB hsibExt famEqn@(FamEqn _ _ _ _ _ dataDef))))))+ DataTypeCons True [_] -> Nothing -- Extension "TypeData": `type data T x = ...`+ _ -> Nothing+singleSimpleField (L loc (InstD ext (DataFamInstD instExt (DataFamInstDecl famEqn@(FamEqn _ _ _ _ _ dataDef))))) | Just inType <- simpleHsDataDefn dataDef =- Just WarnNewtype- { newDecl = L loc $ InstD ext $ DataFamInstD instExt $ DataFamInstDecl $ HsIB hsibExt famEqn {feqn_rhs = dataDef- { dd_ND = NewType- , dd_cons = dropBangs dataDef- }}+ case dropBangs dataDef of+ DataTypeCons False [con] ->+ Just WarnNewtype+ { newDecl = L loc $ InstD ext $ DataFamInstD instExt $ DataFamInstDecl $ famEqn {feqn_rhs = dataDef+ { dd_cons = NewTypeCon con }} , insideType = inType }+ DataTypeCons True [_] -> Nothing -- -- Extension "TypeData": `type data T x = ...`+ _ -> Nothing singleSimpleField _ = Nothing -dropBangs :: HsDataDefn GhcPs -> [LConDecl GhcPs]-dropBangs = map (fmap dropConsBang) . dd_cons+dropBangs :: HsDataDefn GhcPs -> DataDefnCons (LConDecl GhcPs)+dropBangs def =+ case dd_cons def of+ NewTypeCon a -> NewTypeCon (dropConsBang <$> a)+ DataTypeCons isTypeData as -> DataTypeCons isTypeData (map (dropConsBang <$>) as) --- | Checks whether its argument is a \"simple\" data definition (see 'singleSimpleField')--- returning the type inside its constructor if it is.+-- | Checks whether its argument is a \"simple\" data definition (see+-- 'singleSimpleField') returning the single thing under its+-- constructor if it is. simpleHsDataDefn :: HsDataDefn GhcPs -> Maybe (HsType GhcPs)-simpleHsDataDefn (HsDataDefn _ DataType _ _ _ [L _ constructor] _) = simpleCons constructor+simpleHsDataDefn (HsDataDefn _ _ _ _ (DataTypeCons _ [L _ constructor]) _) = simpleCons constructor simpleHsDataDefn _ = Nothing -- | Checks whether its argument is a \"simple\" constructor (see criteria in 'singleSimpleField') -- returning the type inside the constructor if it is. This is needed for strictness analysis. simpleCons :: ConDecl GhcPs -> Maybe (HsType GhcPs)-simpleCons (ConDeclH98 _ _ _ [] context (PrefixCon [HsScaled _ (L _ inType)]) _)+simpleCons (ConDeclH98 _ _ _ [] context (PrefixCon [] [HsScaled _ (L _ inType)]) _) | emptyOrNoContext context , not $ isUnboxedTuple inType , not $ isHashy inType@@ -144,7 +151,7 @@ isHashy x = or ["#" `isSuffixOf` unsafePrettyPrint v | v@HsTyVar{} <- universe x] warnBang :: HsType GhcPs -> Bool-warnBang (HsBangTy _ (HsSrcBang _ _ SrcStrict) _) = False+warnBang (HsBangTy _ (HsBang _ SrcStrict) _) = False warnBang _ = True emptyOrNoContext :: Maybe (LHsContext GhcPs) -> Bool@@ -155,10 +162,10 @@ -- | The \"Bang\" here refers to 'HsSrcBang', which notably also includes @UNPACK@ pragmas! dropConsBang :: ConDecl GhcPs -> ConDecl GhcPs -- fields [HsScaled GhcPs (LBangType GhcPs)]-dropConsBang decl@(ConDeclH98 _ _ _ _ _ (PrefixCon fields) _) =+dropConsBang decl@(ConDeclH98 _ _ _ _ _ (PrefixCon [] fields) _) = -- decl {con_args = PrefixCon $ map getBangType fields} let fs' = map (\(HsScaled s lt) -> HsScaled s (getBangType lt)) fields :: [HsScaled GhcPs (LBangType GhcPs)]- in decl {con_args = PrefixCon fs'}+ in decl {con_args = PrefixCon [] fs'} dropConsBang decl@(ConDeclH98 _ _ _ _ _ (RecCon (L recloc conDeclFields)) _) = decl {con_args = RecCon $ L recloc $ removeUnpacksRecords conDeclFields} where@@ -168,6 +175,7 @@ removeConDeclFieldUnpacks :: ConDeclField GhcPs -> ConDeclField GhcPs removeConDeclFieldUnpacks conDeclField@(ConDeclField _ _ fieldType _) = conDeclField {cd_fld_type = getBangType fieldType}+dropConsBang x = x isUnboxedTuple :: HsType GhcPs -> Bool isUnboxedTuple (HsTupleTy _ HsUnboxedTuple _) = True
+ src/Hint/NumLiteral.hs view
@@ -0,0 +1,119 @@+{-+ Suggest the usage of underscore when NumericUnderscores is enabled.++<TEST>+123456+{-# LANGUAGE NumericUnderscores #-} \+1234+{-# LANGUAGE NumericUnderscores #-} \+12345 -- @Suggestion 12_345 @NoRefactor+{-# LANGUAGE NumericUnderscores #-} \+123456789.0441234e-123456 -- @Suggestion 123_456_789.044_123_4e-123_456 @NoRefactor+{-# LANGUAGE NumericUnderscores #-} \+0x12abc.523defp+172345 -- @Suggestion 0x1_2abc.523d_efp+172_345 @NoRefactor+{-# LANGUAGE NumericUnderscores #-} \+3.14159265359 -- @Suggestion 3.141_592_653_59 @NoRefactor+{-# LANGUAGE NumericUnderscores #-} \+12_33574_56+</TEST>++-}++module Hint.NumLiteral (numLiteralHint) where++import GHC.Hs+import GHC.Data.FastString+import GHC.LanguageExtensions.Type (Extension (..))+import GHC.Types.SrcLoc+import GHC.Types.SourceText+import GHC.Util.ApiAnnotation (extensions)+import Data.Char (isDigit, isOctDigit, isHexDigit)+import Data.List (intercalate)+import Data.Set (union)+import Data.Generics.Uniplate.DataOnly (universeBi)+import Refact.Types++import Hint.Type (DeclHint, toSSA, modComments, firstDeclComments)+import Idea (Idea, suggest)++numLiteralHint :: DeclHint+numLiteralHint _ modu =+ -- Comments appearing without an empty line before the first+ -- declaration in a module are now associated with the declaration+ -- not the module so to be safe, look also at `firstDeclComments+ -- modu` (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).+ let exts = union (extensions (modComments modu)) (extensions (firstDeclComments modu)) in+ if NumericUnderscores `elem` exts then+ concatMap suggestUnderscore . universeBi+ else+ const []++suggestUnderscore :: LHsExpr GhcPs -> [Idea]+suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsIntegral intLit@(IL (SourceText srcTxt) _ _))))) =+ [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` unpackFS srcTxt, unpackFS srcTxt /= underscoredSrcTxt ]+ where+ underscoredSrcTxt = addUnderscore (unpackFS srcTxt)+ y :: LocatedAn NoEpAnns (HsExpr GhcPs)+ y = noLocA $ HsOverLit noExtField $ ol{ol_val = HsIntegral intLit{il_text = SourceText (fsLit underscoredSrcTxt)}}+ r = Replace Expr (toSSA x) [("a", toSSA y)] "a"+suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsFractional fracLit@(FL (SourceText srcTxt) _ _ _ _))))) =+ [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` unpackFS srcTxt, unpackFS srcTxt /= underscoredSrcTxt ]+ where+ underscoredSrcTxt = addUnderscore (unpackFS srcTxt)+ y :: LocatedAn NoEpAnns (HsExpr GhcPs)+ y = noLocA $ HsOverLit noExtField $ ol{ol_val = HsFractional fracLit{fl_text = SourceText (fsLit underscoredSrcTxt)}}+ r = Replace Expr (toSSA x) [("a", toSSA y)] "a"+suggestUnderscore _ = mempty++addUnderscore :: String -> String+addUnderscore intStr = numLitToStr underscoredNumLit+ where+ numLit = toNumLiteral intStr+ underscoredNumLit = numLit{ nl_intPart = underscoreFromRight chunkSize $ nl_intPart numLit+ , nl_fracPart = underscore chunkSize $ nl_fracPart numLit+ , nl_exp = underscoreFromRight 3 $ nl_exp numLit -- Exponential part is always decimal+ }+ chunkSize = if null (nl_prefix numLit) then 3 else 4++ underscore chunkSize = intercalate "_" . chunk chunkSize+ underscoreFromRight chunkSize str+ | length str < 5 = str+ | otherwise = reverse . underscore chunkSize . reverse $ str+ chunk chunkSize [] = []+ chunk chunkSize xs = a:chunk chunkSize b where (a, b) = splitAt chunkSize xs++data NumLiteral = NumLiteral+ { nl_prefix :: String+ , nl_intPart :: String+ , nl_decSep :: String -- decimal separator+ , nl_fracPart :: String+ , nl_expSep :: String -- e, e+, e-, p, p+, p-+ , nl_exp :: String+ } deriving (Show, Eq)++toNumLiteral :: String -> NumLiteral+toNumLiteral str = case str of+ '0':'b':digits -> (afterPrefix isBinDigit digits){nl_prefix = "0b"}+ '0':'B':digits -> (afterPrefix isBinDigit digits){nl_prefix = "0B"}+ '0':'o':digits -> (afterPrefix isOctDigit digits){nl_prefix = "0o"}+ '0':'O':digits -> (afterPrefix isOctDigit digits){nl_prefix = "0O"}+ '0':'x':digits -> (afterPrefix isHexDigit digits){nl_prefix = "0x"}+ '0':'X':digits -> (afterPrefix isHexDigit digits){nl_prefix = "0X"}+ _ -> afterPrefix isDigit str+ where+ isBinDigit x = x == '0' || x == '1'++ afterPrefix isDigit str = (afterIntPart isDigit suffix){nl_intPart = intPart}+ where (intPart, suffix) = span isDigit str++ afterIntPart isDigit ('.':suffix) = (afterDecSep isDigit suffix){nl_decSep = "."}+ afterIntPart isDigit str = afterFracPart str++ afterDecSep isDigit str = (afterFracPart suffix){nl_fracPart = fracPart}+ where (fracPart, suffix) = span isDigit str++ afterFracPart str = NumLiteral "" "" "" "" expSep exp+ where (expSep, exp) = break isDigit str++numLitToStr :: NumLiteral -> String+numLitToStr (NumLiteral p ip ds fp es e) = p ++ ip ++ ds ++ fp ++ es ++ e
src/Hint/Pattern.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE ViewPatterns, PatternGuards, TypeFamilies #-} {-@@ -58,7 +59,7 @@ module Hint.Pattern(patternHint) where -import Hint.Type(DeclHint,Idea,ghcAnnotations,ideaTo,toSS,toRefactSrcSpan,suggest,suggestRemove,warn)+import Hint.Type(DeclHint,Idea,modComments,firstDeclComments,ideaTo,toSSA,toRefactSrcSpan,suggest,suggestRemove,warn) import Data.Generics.Uniplate.DataOnly import Data.Function import Data.List.Extra@@ -66,14 +67,14 @@ import Data.Maybe import Data.Either import Refact.Types hiding (RType(Pattern, Match), SrcSpan)-import qualified Refact.Types as R (RType(Pattern, Match), SrcSpan)+import Refact.Types qualified as R (RType(Pattern, Match), SrcSpan) -import GHC.Hs+import GHC.Hs hiding(asPattern) import GHC.Types.SrcLoc import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence-import GHC.Data.Bag-import GHC.Types.Basic+import GHC.Types.Basic hiding (Pattern)+import GHC.Data.Strict qualified import GHC.Util import Language.Haskell.GhclibParserEx.GHC.Hs.Pat@@ -90,11 +91,16 @@ concatMap (patHint strict True) (universeBi $ transformBi noPatBind x) ++ concatMap expHint (universeBi x) where- exts = nubOrd $ concatMap snd (languagePragmas (pragmas (ghcAnnotations modu))) -- language extensions enabled at source+ -- Comments appearing without an empty line before the first+ -- declaration in a module are now associated with the declaration+ -- not the module so to be safe, look also at `firstDeclComments+ -- modu`+ -- (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).+ exts = nubOrd $ concatMap snd (languagePragmas (pragmas (modComments modu) ++ pragmas (firstDeclComments modu))) -- language extensions enabled at source strict = "Strict" `elem` exts noPatBind :: LHsBind GhcPs -> LHsBind GhcPs- noPatBind (L loc a@PatBind{}) = L loc a{pat_lhs=noLoc (WildPat noExtField)}+ noPatBind (L loc a@PatBind{}) = L loc a{pat_lhs=noLocA (WildPat noExtField)} noPatBind x = x {-@@ -111,16 +117,16 @@ hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea] hints gen (Pattern l rtype pat (GRHSs _ [L _ (GRHS _ [] bod)] bind))- | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GRHSs noExtField guards bind)) [refactoring]]+ | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GRHSs emptyComments guards bind)) [refactoring]] where rawGuards :: [(LHsExpr GhcPs, LHsExpr GhcPs)] rawGuards = asGuards bod mkGuard :: LHsExpr GhcPs -> (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs))- mkGuard a = GRHS noExtField [noLoc $ BodyStmt noExtField a noSyntaxExpr noSyntaxExpr]+ mkGuard a = GRHS noAnn [noLocA $ BodyStmt noExtField a noSyntaxExpr noSyntaxExpr] guards :: [LGRHS GhcPs (LHsExpr GhcPs)]- guards = map (noLoc . uncurry mkGuard) rawGuards+ guards = map (noLocA . uncurry mkGuard) rawGuards (lhs, rhs) = unzip rawGuards @@ -128,7 +134,7 @@ -- Check if the expression has been injected or is natural. zipWith checkLoc ps ['1' .. '9'] where- checkLoc p@(L l _) v = if l == noSrcSpan then Left p else Right (c ++ [v], toSS p)+ checkLoc p@(L l _) v = if locA l == noSrcSpan then Left p else Right (c ++ [v], toSSA p) patSubts = case pat of@@ -137,38 +143,38 @@ ps -> mkTemplate "p100" ps guardSubts = mkTemplate "g100" lhs exprSubts = mkTemplate "e100" rhs- templateGuards = map noLoc (zipWith (mkGuard `on` toString) guardSubts exprSubts)+ templateGuards = map noLocA (zipWith (mkGuard `on` toString) guardSubts exprSubts) toString (Left e) = e toString (Right (v, _)) = strToVar v toString' (Left e) = e toString' (Right (v, _)) = strToPat v - template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString' patSubts) (GRHSs noExtField templateGuards bind)) [])+ template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString' patSubts) (GRHSs emptyComments templateGuards bind)) []) f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)] f = rights refactoring = Replace rtype (toRefactSrcSpan l) (f patSubts ++ f guardSubts ++ f exprSubts) template hints gen (Pattern l t pats o@(GRHSs _ [L _ (GRHS _ [test] bod)] bind)) | unsafePrettyPrint test `elem` ["otherwise", "True"]- = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLoc (GRHS noExtField [] bod)]}) [Delete Stmt (toSS test)]]+ = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLocA (GRHS noAnn [] bod)]}) [Delete Stmt (toSSA test)]] hints _ (Pattern l t pats bod@(GRHSs _ _ binds)) | f binds = [suggestRemove "Redundant where" whereSpan "where" [ {- TODO refactoring for redundant where -} ]] where- f :: LHsLocalBinds GhcPs -> Bool- f (L _ (HsValBinds _ (ValBinds _ bag _))) = isEmptyBag bag- f (L _ (HsIPBinds _ (IPBinds _ l))) = null l+ f :: HsLocalBinds GhcPs -> Bool+ f (HsValBinds _ (ValBinds _ l _)) = null l+ f (HsIPBinds _ (IPBinds _ l)) = null l f _ = False whereSpan = case l of UnhelpfulSpan s -> UnhelpfulSpan s RealSrcSpan s _ -> let end = realSrcSpanEnd s start = mkRealSrcLoc (srcSpanFile s) (srcLocLine end) (srcLocCol end - 5)- in RealSrcSpan (mkRealSrcSpan start end) Nothing+ in RealSrcSpan (mkRealSrcSpan start end) GHC.Data.Strict.Nothing hints gen (Pattern l t pats o@(GRHSs _ (unsnoc -> Just (gs, L _ (GRHS _ [test] bod))) binds)) | unsafePrettyPrint test == "True"- = let otherwise_ = noLoc $ BodyStmt noExtField (strToVar "otherwise") noSyntaxExpr noSyntaxExpr in- [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLoc (GRHS noExtField [otherwise_] bod)]}) [Replace Expr (toSS test) [] "otherwise"]]+ = let otherwise_ = noLocA $ BodyStmt noExtField (strToVar "otherwise") noSyntaxExpr noSyntaxExpr in+ [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLocA (GRHS noAnn [otherwise_] bod)]}) [Replace Expr (toSSA test) [] "otherwise"]] hints _ _ = [] asGuards :: LHsExpr GhcPs -> [(LHsExpr GhcPs, LHsExpr GhcPs)]@@ -183,27 +189,27 @@ asPattern (L loc x) = concatMap decl (universeBi x) where decl :: HsBind GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]- decl o@(PatBind _ pat rhs _) = [(Pattern loc Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest msg (L loc o :: LHsBind GhcPs) (noLoc (PatBind noExtField pat rhs ([], [])) :: LHsBind GhcPs) rs)]- decl (FunBind _ _ (MG _ (L _ xs) _) _) = map match xs+ decl o@(PatBind _ pat mult rhs) = [(Pattern (locA loc) Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest msg (noLoc o :: Located (HsBind GhcPs)) (noLoc (PatBind noExtField pat mult rhs) :: Located (HsBind GhcPs)) rs)]+ decl (FunBind _ _ (MG _ (L _ xs))) = map match xs decl _ = [] match :: LMatch GhcPs (LHsExpr GhcPs) -> (Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)- match o@(L loc (Match _ ctx pats grhss)) = (Pattern loc R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest msg o (noLoc (Match noExtField ctx pats grhss) :: LMatch GhcPs (LHsExpr GhcPs)) rs)+ match o@(L loc (Match _ ctx (L lpats pats) grhss)) = (Pattern (locA loc) R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest msg (reLoc o) (noLoc (Match noExtField ctx (L lpats pats) grhss) :: Located (Match GhcPs (LHsExpr GhcPs))) rs) -- First Bool is if 'Strict' is a language extension. Second Bool is -- if this pattern in this context is going to be evaluated strictly. patHint :: Bool -> Bool -> LPat GhcPs -> [Idea]-patHint _ _ o@(L _ (ConPat _ name (PrefixCon args)))+patHint _ _ o@(L _ (ConPat _ name (PrefixCon _ args))) | length args >= 3 && all isPWildcard args =- let rec_fields = HsRecFields [] Nothing :: HsRecFields GhcPs (LPat GhcPs)- new = noLoc $ ConPat noExtField name (RecCon rec_fields) :: LPat GhcPs+ let rec_fields = HsRecFields noExtField [] Nothing :: HsRecFields GhcPs (LPat GhcPs)+ new = noLocA $ ConPat noAnn name (RecCon rec_fields) :: LPat GhcPs in- [suggest "Use record patterns" o new [Replace R.Pattern (toSS o) [] (unsafePrettyPrint new)]]+ [suggest "Use record patterns" (reLoc o) (reLoc new) [Replace R.Pattern (toSSA o) [] (unsafePrettyPrint new)]] patHint _ _ o@(L _ (VarPat _ (L _ name))) | occNameString (rdrNameOcc name) == "otherwise" =- [warn "Used otherwise as a pattern" o (noLoc (WildPat noExtField) :: LPat GhcPs) []]+ [warn "Used otherwise as a pattern" (reLoc o) (noLoc (WildPat noExtField) :: Located (Pat GhcPs)) []] patHint lang strict o@(L _ (BangPat _ pat@(L _ x)))- | strict, f x = [warn "Redundant bang pattern" o (noLoc x :: LPat GhcPs) [r]]+ | strict, f x = [warn "Redundant bang pattern" (reLoc o) (noLoc x :: Located (Pat GhcPs)) [r]] where f :: Pat GhcPs -> Bool f (ParPat _ (L _ x)) = f x@@ -215,9 +221,9 @@ f ListPat {} = True f (SigPat _ (L _ p) _) = f p f _ = False- r = Replace R.Pattern (toSS o) [("x", toSS pat)] "x"+ r = Replace R.Pattern (toSSA o) [("x", toSSA pat)] "x" patHint False _ o@(L _ (LazyPat _ pat@(L _ x)))- | f x = [warn "Redundant irrefutable pattern" o (noLoc x :: LPat GhcPs) [r]]+ | f x = [warn "Redundant irrefutable pattern" (reLoc o) (noLoc x :: Located (Pat GhcPs)) [r]] where f :: Pat GhcPs -> Bool f (ParPat _ (L _ x)) = f x@@ -225,20 +231,20 @@ f WildPat{} = True f VarPat{} = True f _ = False- r = Replace R.Pattern (toSS o) [("x", toSS pat)] "x"+ r = Replace R.Pattern (toSSA o) [("x", toSSA pat)] "x" patHint _ _ o@(L _ (AsPat _ v (L _ (WildPat _)))) =- [warn "Redundant as-pattern" o v [Replace R.Pattern (toSS o) [] (rdrNameStr v)]]+ [warn "Redundant as-pattern" (reLoc o) (reLoc v) [Replace R.Pattern (toSSA o) [] (rdrNameStr v)]] patHint _ _ _ = [] expHint :: LHsExpr GhcPs -> [Idea] -- Note the 'FromSource' in these equations (don't warn on generated match groups).-expHint o@(L _ (HsCase _ _ (MG _ (L _ [L _ (Match _ CaseAlt [L _ (WildPat _)] (GRHSs _ [L _ (GRHS _ [] e)] (L _ (EmptyLocalBinds _)))) ]) FromSource ))) =- [suggest "Redundant case" o e [r]]+expHint o@(L _ (HsCase _ _ (MG FromSource (L _ [L _ (Match _ CaseAlt (L _ [L _ (WildPat _)]) (GRHSs _ [L _ (GRHS _ [] e)] (EmptyLocalBinds _))) ])))) =+ [suggest "Redundant case" (reLoc o) (reLoc e) [r]] where- r = Replace Expr (toSS o) [("x", toSS e)] "x"-expHint o@(L _ (HsCase _ (L _ (HsVar _ (L _ x))) (MG _ (L _ [L _ (Match _ CaseAlt [L _ (VarPat _ (L _ y))] (GRHSs _ [L _ (GRHS _ [] e)] (L _ (EmptyLocalBinds _)))) ]) FromSource )))+ r = Replace Expr (toSSA o) [("x", toSSA e)] "x"+expHint o@(L _ (HsCase _ (L _ (HsVar _ (L _ x))) (MG FromSource (L _ [L _ (Match _ CaseAlt (L _ [L _ (VarPat _ (L _ y))]) (GRHSs _ [L _ (GRHS _ [] e)] (EmptyLocalBinds _))) ])))) | occNameStr x == occNameStr y =- [suggest "Redundant case" o e [r]]+ [suggest "Redundant case" (reLoc o) (reLoc e) [r]] where- r = Replace Expr (toSS o) [("x", toSS e)] "x"+ r = Replace Expr (toSSA o) [("x", toSSA e)] "x" expHint _ = []
src/Hint/Pragma.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} @@ -25,35 +26,40 @@ {-# LANGUAGE RebindableSyntax #-} \ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RebindableSyntax #-} \-{-# LANGUAGE EmptyCase, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase #-}+{-# LANGUAGE EmptyCase, RebindableSyntax #-} -- {-# LANGUAGE EmptyCase, RebindableSyntax #-} </TEST> -} module Hint.Pragma(pragmaHint) where -import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),toSS,rawIdea)+import Hint.Type(ModuHint,Idea(..),Severity(..),toSSAnc,rawIdea,modComments,firstDeclComments) import Data.List.Extra-import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty qualified as NE import Data.Maybe import Refact.Types-import qualified Refact.Types as R+import Refact.Types qualified as R -import GHC.Parser.Annotation+import GHC.Hs import GHC.Types.SrcLoc+import GHC.Data.FastString import GHC.Util import GHC.Driver.Session pragmaHint :: ModuHint pragmaHint _ modu =- let ps = pragmas (ghcAnnotations modu)+ -- Comments appearing without a line-break before the first+ -- declaration in a module are now associated with the declaration+ -- not the module so to be safe, look also at `firstDeclComments+ -- modu` (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).+ let ps = pragmas (modComments modu) ++ pragmas (firstDeclComments modu) opts = flags ps lang = languagePragmas ps in languageDupes lang ++ optToPragma opts lang -optToPragma :: [(Located AnnotationComment, [String])]- -> [(Located AnnotationComment, [String])]+optToPragma :: [(LEpaComment, [String])]+ -> [(LEpaComment, [String])] -> [Idea] optToPragma flags languagePragmas = [pragmaIdea (OptionsToComment (fst <$> old2) ys rs) | Just old2 <- [NE.nonEmpty old]]@@ -66,40 +72,44 @@ ls = concatMap snd languagePragmas ns2 = nubOrd (concat ns) \\ ls - ys = [mkLanguagePragmas noSrcSpan ns2 | ns2 /= []] ++ catMaybes new- mkRefact :: (Located AnnotationComment, [String])- -> Maybe (Located AnnotationComment)+ dummyLoc = mkRealSrcLoc (fsLit "dummy") 1 1+ dummySpan = mkRealSrcSpan dummyLoc dummyLoc+ dummyAnchor = realSpanAsAnchor dummySpan++ ys = [mkLanguagePragmas dummyAnchor ns2 | ns2 /= []] ++ catMaybes new+ mkRefact :: (LEpaComment, [String])+ -> Maybe LEpaComment -> [String] -> Refactoring R.SrcSpan- mkRefact old (maybe "" comment -> new) ns =- let ns' = map (\n -> comment (mkLanguagePragmas noSrcSpan [n])) ns- in ModifyComment (toSS (fst old)) (intercalate "\n" (filter (not . null) (ns' `snoc` new)))+ mkRefact old (maybe "" comment_ -> new) ns =+ let ns' = map (\n -> comment_ (mkLanguagePragmas dummyAnchor [n])) ns+ in ModifyComment (toSSAnc (fst old)) (intercalate "\n" (filter (not . null) (ns' `snoc` new))) -data PragmaIdea = SingleComment (Located AnnotationComment) (Located AnnotationComment)- | MultiComment (Located AnnotationComment) (Located AnnotationComment) (Located AnnotationComment)- | OptionsToComment (NE.NonEmpty (Located AnnotationComment)) [Located AnnotationComment] [Refactoring R.SrcSpan]+data PragmaIdea = SingleComment LEpaComment LEpaComment+ | MultiComment LEpaComment LEpaComment LEpaComment+ | OptionsToComment (NE.NonEmpty LEpaComment) [LEpaComment] [Refactoring R.SrcSpan] pragmaIdea :: PragmaIdea -> Idea pragmaIdea pidea = case pidea of SingleComment old new ->- mkFewer (getLoc old) (comment old) (Just $ comment new) []- [ModifyComment (toSS old) (comment new)]+ mkFewer (getAncLoc old) (comment_ old) (Just $ comment_ new) []+ [ModifyComment (toSSAnc old) (comment_ new)] MultiComment repl delete new ->- mkFewer (getLoc repl)- (f [repl, delete]) (Just $ comment new) []- [ ModifyComment (toSS repl) (comment new)- , ModifyComment (toSS delete) ""]+ mkFewer (getAncLoc repl)+ (f [repl, delete]) (Just $ comment_ new) []+ [ ModifyComment (toSSAnc repl) (comment_ new)+ , ModifyComment (toSSAnc delete) ""] OptionsToComment old new r ->- mkLanguage (getLoc . NE.head $ old)+ mkLanguage (getAncLoc . NE.head $ old) (f $ NE.toList old) (Just $ f new) [] r where- f = unlines . map comment+ f = unlines . map comment_ mkFewer = rawIdea Hint.Type.Warning "Use fewer LANGUAGE pragmas" mkLanguage = rawIdea Hint.Type.Warning "Use LANGUAGE pragmas" -languageDupes :: [(Located AnnotationComment, [String])] -> [Idea]+languageDupes :: [(LEpaComment, [String])] -> [Idea] languageDupes ( (a@(L l _), les) : cs ) = (if nubOrd les /= les then [pragmaIdea (SingleComment a (mkLanguagePragmas l $ nubOrd les))]@@ -126,15 +136,15 @@ -- extension enabling flags. Return that together with a list of any -- language extensions enabled by this pragma that are not otherwise -- enabled by LANGUAGE pragmas in the module.-optToLanguage :: (Located AnnotationComment, [String])+optToLanguage :: (LEpaComment, [String]) -> [String]- -> Maybe (Maybe (Located AnnotationComment), [String])+ -> Maybe (Maybe LEpaComment, [String]) optToLanguage (L loc _, flags) languagePragmas | any isJust vs = -- 'ls' is a list of language features enabled by this -- OPTIONS_GHC pragma that are not enabled by LANGUAGE pragmas -- in this module.- let ls = filter (not . (`elem` languagePragmas)) (concat $ catMaybes vs) in+ let ls = concatMap (filter (`notElem` languagePragmas)) $ catMaybes vs in Just (res, ls) where -- Try reinterpreting each flag as a list of language features
src/Hint/Restrict.hs view
@@ -1,5 +1,5 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}@@ -21,25 +21,28 @@ </TEST> -} -import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),warn,rawIdea)+import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),warn,rawIdea,modComments,firstDeclComments) import Config.Type+import Util import Data.Generics.Uniplate.DataOnly-import qualified Data.List.NonEmpty as NonEmpty-import qualified Data.Set as Set-import qualified Data.Map as Map+import Data.List.NonEmpty qualified as NonEmpty+import Data.Set qualified as Set+import Data.Map qualified as Map import Data.List.Extra+import Data.List.NonEmpty (nonEmpty)+import Data.Either import Data.Maybe+import Data.Monoid import Data.Semigroup import Data.Tuple.Extra import Control.Applicative import Control.Monad+import Control.Monad.Extra import Prelude import GHC.Hs import GHC.Types.Name.Reader-import GHC.Parser.Annotation-import GHC.Unit.Module import GHC.Types.SrcLoc import GHC.Types.Name.Occurrence import Language.Haskell.GhclibParserEx.GHC.Hs@@ -49,8 +52,14 @@ -- FIXME: The settings should be partially applied, but that's hard to orchestrate right now restrictHint :: [Setting] -> ModuHint restrictHint settings scope m =- let anns = ghcAnnotations m- ps = pragmas anns+ -- Comments appearing without an empty line before the first+ -- declaration in a module are now associated with the declaration+ -- not the module so to be safe, look also at `firstDeclComments+ -- modu`+ -- (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).+ let annsMod = modComments m+ annsFirstDecl = firstDeclComments m+ ps = pragmas annsMod ++ pragmas annsFirstDecl opts = flags ps exts = languagePragmas ps in checkPragmas modu opts exts rOthers ++@@ -65,13 +74,18 @@ data RestrictItem = RestrictItem {riAs :: [String]+ ,riAsRequired :: Alt Maybe Bool+ ,riImportStyle :: Alt Maybe RestrictImportStyle+ ,riQualifiedStyle :: Alt Maybe QualifiedStyle ,riWithin :: [(String, String)]- ,riBadIdents :: [String]+ ,riRestrictIdents :: RestrictIdents ,riMessage :: Maybe String } instance Semigroup RestrictItem where- RestrictItem x1 x2 x3 x4 <> RestrictItem y1 y2 y3 y4 = RestrictItem (x1<>y1) (x2<>y2) (x3<>y3) (x4<>y4)+ RestrictItem x1 x2 x3 x4 x5 x6 x7+ <> RestrictItem y1 y2 y3 y4 y5 y6 y7+ = RestrictItem (x1<>y1) (x2<>y2) (x3<>y3) (x4<>y4) (x5<>y5) (x6<>y6) (x7<>y7) -- Contains a map from module (Nothing if the rule is unqualified) to (within, message), so that we can -- distinguish functions with the same name.@@ -97,7 +111,17 @@ rOthers = Map.map f $ Map.fromListWith (++) (map (second pure) ros) f rs = (all restrictDefault rs- ,Map.fromListWith (<>) [(s, RestrictItem restrictAs restrictWithin restrictBadIdents restrictMessage) | Restrict{..} <- rs, s <- restrictName])+ ,Map.fromListWith (<>)+ [(,) s RestrictItem+ { riAs = restrictAs+ , riAsRequired = restrictAsRequired+ , riImportStyle = restrictImportStyle+ , riQualifiedStyle = restrictQualifiedStyle+ , riWithin = restrictWithin+ , riRestrictIdents = restrictIdents+ , riMessage = restrictMessage+ }+ | Restrict{..} <- rs, s <- restrictName]) ideaMessage :: Maybe String -> Idea -> Idea ideaMessage (Just message) w = w{ideaNote=[Note message]}@@ -110,60 +134,134 @@ noteMayBreak = Note "may break the code" within :: String -> String -> [(String, String)] -> Bool-within modu func = any (\(a,b) -> (a == modu || a == "") && (b == func || b == ""))+within modu func = any (\(a,b) -> (a ~= modu || a == "") && (b ~= func || b == ""))+ where (~=) = wildcardMatch --------------------------------------------------------------------- -- CHECKS checkPragmas :: String- -> [(Located AnnotationComment, [String])]- -> [(Located AnnotationComment, [String])]+ -> [(LEpaComment, [String])]+ -> [(LEpaComment, [String])] -> Map.Map RestrictType (Bool, Map.Map String RestrictItem) -> [Idea] checkPragmas modu flags exts mps = f RestrictFlag "flags" flags ++ f RestrictExtension "extensions" exts where f tag name xs =- [(if null good then ideaNoTo else id) $ notes $ rawIdea Hint.Type.Warning ("Avoid restricted " ++ name) l c Nothing [] []+ [(if null good then ideaNoTo else id) $ notes $ rawIdea Hint.Type.Warning ("Avoid restricted " ++ name) (getAncLoc l) c Nothing [] [] | Just (def, mp) <- [Map.lookup tag mps]- , (L l (AnnBlockComment c), les) <- xs+ , (l@(L _ (EpaComment (EpaBlockComment c) _)), les) <- xs , let (good, bad) = partition (isGood def mp) les , let note = maybe noteMayBreak Note . (=<<) riMessage . flip Map.lookup mp , let notes w = w {ideaNote=note <$> bad} , not $ null bad] isGood def mp x = maybe def (within modu "" . riWithin) $ Map.lookup x mp ++-- | Extension to GHC's 'ImportDeclQualifiedStyle', expressing @qualifiedStyle: unrestricted@,+-- i.e. the preference of "either pre- or post-, but qualified" in a rule.+data QualifiedPostOrPre = QualifiedPostOrPre deriving Eq+ checkImports :: String -> [LImportDecl GhcPs] -> (Bool, Map.Map String RestrictItem) -> [Idea]-checkImports modu imp (def, mp) =- [ ideaMessage riMessage- $ if | not allowImport -> ideaNoTo $ warn "Avoid restricted module" i i []- | not allowIdent -> ideaNoTo $ warn "Avoid restricted identifiers" i i []- | not allowQual -> warn "Avoid restricted qualification" i (noLoc $ (unLoc i){ ideclAs=noLoc . mkModuleName <$> listToMaybe riAs} :: Located (ImportDecl GhcPs)) []- | otherwise -> error "checkImports: unexpected case"- | i@(L _ ImportDecl {..}) <- imp- , let RestrictItem{..} = Map.findWithDefault (RestrictItem [] [("","") | def] [] Nothing) (moduleNameString (unLoc ideclName)) mp- , let allowImport = within modu "" riWithin- , let allowIdent = Set.disjoint- (Set.fromList riBadIdents)- (Set.fromList (maybe [] (\(b, lxs) -> if b then [] else concatMap (importListToIdents . unLoc) (unLoc lxs)) ideclHiding))- , let allowQual = maybe True (\x -> null riAs || moduleNameString (unLoc x) `elem` riAs) ideclAs- , not allowImport || not allowQual || not allowIdent- ]+checkImports modu lImportDecls (def, mp) = mapMaybe getImportHint lImportDecls+ where+ getImportHint :: LImportDecl GhcPs -> Maybe Idea+ getImportHint i@(L _ ImportDecl{..}) = do+ let RestrictItem{..} = getRestrictItem def ideclName mp+ either (Just . ideaMessage riMessage) (const Nothing) $ do+ unless (within modu "" riWithin) $+ Left $ ideaNoTo $ warn "Avoid restricted module" (reLoc i) (reLoc i) [] + let importedIdents = Set.fromList $+ case first (== EverythingBut) <$> ideclImportList of+ Just (False, lxs) -> concatMap (importListToIdents . unLoc) (unLoc lxs)+ _ -> []+ invalidIdents = case riRestrictIdents of+ NoRestrictIdents -> Set.empty+ ForbidIdents badIdents -> importedIdents `Set.intersection` Set.fromList badIdents+ OnlyIdents onlyIdents -> importedIdents `Set.difference` Set.fromList onlyIdents+ unless (Set.null invalidIdents) $+ Left $ ideaNoTo $ warn "Avoid restricted identifiers" (reLoc i) (reLoc i) []++ let qualAllowed = case (riAs, ideclAs) of+ ([], _) -> True+ (_, Nothing) -> maybe True not $ getAlt riAsRequired+ (_, Just (L _ modName)) -> moduleNameString modName `elem` riAs+ unless qualAllowed $ do+ let i' = noLoc $ (unLoc i){ ideclAs = noLocA . mkModuleName <$> listToMaybe riAs }+ Left $ warn "Avoid restricted alias" (reLoc i) i' []++ let (expectedQual, expectedHiding) =+ case fromMaybe ImportStyleUnrestricted $ getAlt riImportStyle of+ ImportStyleUnrestricted+ | NotQualified <- ideclQualified -> (Nothing, Nothing)+ | otherwise -> (Just $ second (<> " or unqualified") expectedQualStyle, Nothing)+ ImportStyleQualified -> (Just expectedQualStyle, Nothing)+ ImportStyleExplicitOrQualified+ | Just (False, _) <- first (== EverythingBut) <$> ideclImportList -> (Nothing, Nothing)+ | otherwise ->+ ( Just $ second (<> " or with an explicit import list") expectedQualStyle+ , Nothing )+ ImportStyleExplicit+ | Just (False, _) <- first (== EverythingBut) <$> ideclImportList -> (Nothing, Nothing)+ | otherwise ->+ ( Just (Right NotQualified, "unqualified")+ , Just $ Just (Exactly, noLocA []) )+ ImportStyleUnqualified -> (Just (Right NotQualified, "unqualified"), Nothing)+ expectedQualStyle =+ case fromMaybe QualifiedStyleUnrestricted $ getAlt riQualifiedStyle of+ QualifiedStyleUnrestricted -> (Left QualifiedPostOrPre, "qualified")+ QualifiedStylePost -> (Right QualifiedPost, "post-qualified")+ QualifiedStylePre -> (Right QualifiedPre, "pre-qualified")+ -- unless expectedQual is Nothing, it holds the Idea (hint) to ultimately emit,+ -- except in these cases when the rule's requirements are fulfilled in-source:+ qualIdea+ -- the rule demands a particular importStyle, and the decl obeys exactly+ | Just (Right ideclQualified) == (fst <$> expectedQual) = Nothing+ -- the rule demands a QualifiedPostOrPre import, and the decl does either+ | Just (Left QualifiedPostOrPre) == (fst <$> expectedQual)+ && ideclQualified `elem` [QualifiedPost, QualifiedPre] = Nothing+ -- otherwise, expectedQual gets converted into a warning below (or is Nothing)+ | otherwise = expectedQual+ whenJust qualIdea $ \(qual, hint) -> do+ -- convert non-Nothing qualIdea into hlint's refactoring Idea+ let i' = noLoc $ (unLoc i){ ideclQualified = fromRight QualifiedPre qual+ , ideclImportList = fromMaybe ideclImportList expectedHiding }+ msg = moduleNameString (unLoc ideclName) <> " should be imported " <> hint+ Left $ warn msg (reLoc i) i' []++getRestrictItem :: Bool -> LocatedA ModuleName -> Map.Map String RestrictItem -> RestrictItem+getRestrictItem def ideclName =+ fromMaybe (RestrictItem mempty mempty mempty mempty [("","") | def] NoRestrictIdents Nothing)+ . lookupRestrictItem ideclName++lookupRestrictItem :: LocatedA ModuleName -> Map.Map String RestrictItem -> Maybe RestrictItem+lookupRestrictItem ideclName mp =+ let moduleName = moduleNameString $ unLoc ideclName+ exact = Map.lookup moduleName mp+ wildcard = nonEmpty+ . fmap snd+ . reverse -- the hope is less specific matches will end up last, but it's not guaranteed+ . filter (liftA2 (&&) (elem '*') (`wildcardMatch` moduleName) . fst)+ $ Map.toList mp+ in exact <> sconcat (sequence wildcard)+ importListToIdents :: IE GhcPs -> [String] importListToIdents = catMaybes .- \case (IEVar _ n) -> [fromName n]- (IEThingAbs _ n) -> [fromName n]- (IEThingAll _ n) -> [fromName n]- (IEThingWith _ n _ ns _) -> fromName n : map fromName ns+ \case (IEVar _ n _) -> [fromName n]+ (IEThingAbs _ n _) -> [fromName n]+ (IEThingAll _ n _) -> [fromName n]+ (IEThingWith _ n _ ns _) -> fromName n : map fromName ns _ -> [] where- fromName :: LIEWrappedName (IdP GhcPs) -> Maybe String- fromName wrapped = case unLoc wrapped of- IEName n -> fromId (unLoc n)- IEPattern n -> ("pattern " ++) <$> fromId (unLoc n)- IEType n -> ("type " ++) <$> fromId (unLoc n)+ fromName :: LIEWrappedName GhcPs -> Maybe String+ fromName wrapped =+ case unLoc wrapped of+ IEName _ n -> fromId (unLoc n)+ IEPattern _ n -> ("pattern " ++) <$> fromId (unLoc n)+ IEType _ n -> ("type " ++) <$> fromId (unLoc n) fromId :: IdP GhcPs -> Maybe String fromId (Unqual n) = Just $ occNameString n@@ -173,10 +271,10 @@ checkFunctions :: Scope -> String -> [LHsDecl GhcPs] -> RestrictFunctions -> [Idea] checkFunctions scope modu decls (def, mp) =- [ (ideaMessage message $ ideaNoTo $ warn "Avoid restricted function" x x []){ideaDecl = [dname]}+ [ (ideaMessage message $ ideaNoTo $ warn "Avoid restricted function" (reLoc x) (reLoc x) []){ideaDecl = [dname]} | d <- decls , let dname = fromMaybe "" (declName d)- , x <- universeBi d :: [Located RdrName]+ , x <- universeBi d :: [LocatedN RdrName] , let xMods = possModules scope x , let (withins, message) = fromMaybe ([("","") | def], Nothing) (findFunction mp x xMods) , not $ within modu dname withins@@ -188,7 +286,7 @@ -- withins and messages are concatenated with (<>). findFunction :: Map.Map String RestrictFunction- -> Located RdrName+ -> LocatedN RdrName -> [ModuleName] -> Maybe ([(String, String)], Maybe String) findFunction restrictMap (rdrNameStr -> x) (map moduleNameString -> possMods) = do
src/Hint/Smell.hs view
@@ -1,8 +1,6 @@+{-# LANGUAGE ImportQualifiedPost #-} -module Hint.Smell (- smellModuleHint,- smellHint- ) where+module Hint.Smell (smellModuleHint,smellHint) where {- <TEST> [{smell: { type: many arg functions, limit: 2 }}]@@ -83,13 +81,13 @@ import Data.Generics.Uniplate.DataOnly import Data.List.Extra-import qualified Data.Map as Map+import Data.Map qualified as Map +import GHC.Utils.Outputable import GHC.Types.Basic import GHC.Hs-import GHC.Utils.Outputable-import GHC.Data.Bag import GHC.Types.SrcLoc+import GHC.Types.Name.Reader import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable smellModuleHint :: [Setting] -> ModuHint@@ -98,7 +96,7 @@ imports = hsmodImports mod in case Map.lookup SmellManyImports (smells settings) of Just n | length imports >= n ->- let span = foldl1 combineSrcSpans $ getLoc <$> imports+ let span = foldl1 combineSrcSpans $ locA . getLoc <$> imports displayImports = unlines $ f <$> imports in [rawIdea Config.Type.Warning "Many imports" span displayImports Nothing [] [] ] where@@ -131,7 +129,7 @@ declSpans (L _ (ValD _ FunBind {fun_matches=MG {- mg_origin=FromSource+ mg_ext=FromSource , mg_alts=(L _ [L _ Match { m_ctxt=ctx , m_grhss=GRHSs{grhssGRHSs=[locGrhs]@@ -140,19 +138,19 @@ -- the where clause. rhsSpans ctx locGrhs ++ whereSpans where_ -- Any other kind of function.-declSpans f@(L l (ValD _ FunBind {})) = [(l, warn "Long function" f f [])]+declSpans f@(L l (ValD _ FunBind {})) = [(locA l, warn "Long function" (reLoc f) (reLoc f) [])] declSpans _ = [] -- The span of a guarded right hand side.-rhsSpans :: HsMatchContext GhcPs -> LGRHS GhcPs (LHsExpr GhcPs) -> [(SrcSpan, Idea)]+rhsSpans :: HsMatchContext (GenLocated SrcSpanAnnN RdrName) -> LGRHS GhcPs (LHsExpr GhcPs) -> [(SrcSpan, Idea)] rhsSpans _ (L _ (GRHS _ _ (L _ RecordCon {}))) = [] -- record constructors get a pass rhsSpans ctx (L _ r@(GRHS _ _ (L l _))) =- [(l, rawIdea Config.Type.Warning "Long function" l (showSDocUnsafe (pprGRHS ctx r)) Nothing [] [])]+ [(locA l, rawIdea Config.Type.Warning "Long function" (locA l) (showSDocUnsafe (pprGRHS ctx r)) Nothing [] [])] -- The spans of a 'where' clause are the spans of its bindings.-whereSpans :: LHsLocalBinds GhcPs -> [(SrcSpan, Idea)]-whereSpans (L l (HsValBinds _ (ValBinds _ bs _))) =- concatMap (declSpans . (\(L loc bind) -> L loc (ValD noExtField bind))) (bagToList bs)+whereSpans :: HsLocalBinds GhcPs -> [(SrcSpan, Idea)]+whereSpans (HsValBinds _ (ValBinds _ bs _)) =+ concatMap (declSpans . (\(L loc bind) -> L loc (ValD noExtField bind))) bs whereSpans _ = [] spanLength :: SrcSpan -> Int@@ -160,16 +158,16 @@ spanLength (UnhelpfulSpan _) = -1 smellLongTypeLists :: LHsDecl GhcPs -> Int -> [Idea]-smellLongTypeLists d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (L _ t)))))) n =- warn "Long type list" d d [] <$ filter longTypeList (universe t)+smellLongTypeLists d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (L _ (HsSig _ _ (L _ t))))))) n =+ warn "Long type list" (reLoc d) (reLoc d) [] <$ filter longTypeList (universe t) where longTypeList (HsExplicitListTy _ IsPromoted x) = length x >= n longTypeList _ = False smellLongTypeLists _ _ = [] smellManyArgFunctions :: LHsDecl GhcPs -> Int -> [Idea]-smellManyArgFunctions d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (L _ t)))))) n =- warn "Many arg function" d d [] <$ filter manyArgFunction (universe t)+smellManyArgFunctions d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (L _ (HsSig _ _ (L _ t))))))) n =+ warn "Many arg function" (reLoc d) (reLoc d) [] <$ filter manyArgFunction (universe t) where manyArgFunction t = countFunctionArgs t >= n smellManyArgFunctions _ _ = []
src/Hint/Unsafe.hs view
@@ -18,7 +18,7 @@ module Hint.Unsafe(unsafeHint) where -import Hint.Type(DeclHint,ModuleEx(..),Severity(..),rawIdea,toSS)+import Hint.Type(DeclHint,ModuleEx(..),Severity(..),rawIdea,toSSA) import Data.List.Extra import Refact.Types hiding(Match) import Data.Generics.Uniplate.DataOnly@@ -28,6 +28,7 @@ import GHC.Types.Name.Reader import GHC.Data.FastString import GHC.Types.Basic+import GHC.Types.SourceText import GHC.Types.SrcLoc import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable@@ -45,31 +46,34 @@ -- @ -- is. We advise that such constants should have a @NOINLINE@ pragma. unsafeHint :: DeclHint-unsafeHint _ (ModuleEx (L _ m) _) = \(L loc d) ->- [rawIdea Hint.Type.Warning "Missing NOINLINE pragma" loc+unsafeHint _ (ModuleEx (L _ m)) = \ld@(L loc d) ->+ [rawIdea Hint.Type.Warning "Missing NOINLINE pragma" (locA loc) (unsafePrettyPrint d) (Just $ trimStart (unsafePrettyPrint $ gen x) ++ "\n" ++ unsafePrettyPrint d)- [] [InsertComment (toSS (L loc d)) (unsafePrettyPrint $ gen x)]+ [] [InsertComment (toSSA ld) (unsafePrettyPrint $ gen x)] -- 'x' does not declare a new function. | d@(ValD _ FunBind {fun_id=L _ (Unqual x)- , fun_matches=MG{mg_origin=FromSource,mg_alts=L _ [L _ Match {m_pats=[]}]}}) <- [d]- -- 'x' is a synonym for an appliciation involing 'unsafePerformIO'+ , fun_matches=MG{mg_ext=FromSource,mg_alts=L _ [L _ Match {m_pats=L _ []}]}}) <- [d]+ -- 'x' is a synonym for an application involving 'unsafePerformIO' , isUnsafeDecl d -- 'x' is not marked 'NOINLINE'. , x `notElem` noinline] where+ noInline :: FastString+ noInline = fsLit $ '{' : '-' : '#' : " NOINLINE"+ gen :: OccName -> LHsDecl GhcPs- gen x = noLoc $- SigD noExtField (InlineSig noExtField (noLoc (mkRdrUnqual x))- (InlinePragma (SourceText "{-# NOINLINE") NoInline Nothing NeverActive FunLike))+ gen x = noLocA $+ SigD noExtField (InlineSig noAnn (noLocA (mkRdrUnqual x))+ (InlinePragma (SourceText noInline) (NoInline (SourceText noInline)) Nothing NeverActive FunLike)) noinline :: [OccName] noinline = [q | L _(SigD _ (InlineSig _ (L _ (Unqual q))- (InlinePragma _ NoInline Nothing NeverActive FunLike))+ (InlinePragma _ (NoInline (SourceText noInline)) Nothing NeverActive FunLike)) ) <- hsmodDecls m] isUnsafeDecl :: HsDecl GhcPs -> Bool-isUnsafeDecl (ValD _ FunBind {fun_matches=MG {mg_origin=FromSource,mg_alts=L _ alts}}) =+isUnsafeDecl (ValD _ FunBind {fun_matches=MG {mg_ext=FromSource,mg_alts=L _ alts}}) = any isUnsafeApp (childrenBi alts) || any isUnsafeDecl (childrenBi alts) isUnsafeDecl _ = False
src/Idea.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE RecordWildCards, NoMonomorphismRestriction #-} module Idea(@@ -13,7 +14,7 @@ import Config.Type import HsColour import Refact.Types hiding (SrcSpan)-import qualified Refact.Types as R+import Refact.Types qualified as R import Prelude import GHC.Types.SrcLoc import GHC.Utils.Outputable@@ -36,7 +37,7 @@ deriving Eq -- I don't use aeson here for 2 reasons:--- 1) Aeson doesn't esape unicode characters, and I want to (allows me to ignore encoding)+-- 1) Aeson doesn't escape unicode characters, and I want to (allows me to ignore encoding) -- 2) I want to control the format so it's slightly human readable as well showIdeaJson :: Idea -> String showIdeaJson idea@Idea{ideaSpan=srcSpan@SrcSpan{..}, ..} = dict
src/Language/Haskell/HLint.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE PatternGuards, RecordWildCards #-} -- | This module provides a way to apply HLint hints. If you want to just run @hlint@ in-process@@ -23,7 +24,7 @@ -- * Hints Hint, -- * Modules- ModuleEx, parseModuleEx, createModuleEx, ParseError(..),+ ModuleEx, parseModuleEx, createModuleEx, createModuleExWithFixities, ParseError(..), -- * Parse flags defaultParseFlags, ParseFlags(..), CppFlags(..), FixityInfo,@@ -33,13 +34,13 @@ import Config.Type import Config.Read import Idea-import qualified Apply as H+import Apply qualified as H import HLint import Fixity import GHC.Data.FastString ( unpackFS ) import GHC.All import Hint.All hiding (resolveHints)-import qualified Hint.All as H+import Hint.All qualified as H import GHC.Types.SrcLoc import CmdLine import Paths_hlint@@ -49,6 +50,7 @@ import System.FilePath import Data.Functor import Prelude+import Hint.Restrict qualified as Restrict -- | Get the Cabal configured data directory of HLint.@@ -56,7 +58,7 @@ getHLintDataDir = getDataDir --- | The function produces a tuple containg 'ParseFlags' (for 'parseModuleEx'),+-- | The function produces a tuple containing 'ParseFlags' (for 'parseModuleEx'), -- and 'Classify' and 'Hint' for 'applyHints'. -- It approximates the normal HLint configuration steps, roughly: --@@ -116,7 +118,9 @@ splitSettings xs = ([x | Infix x <- xs] ,[x | SettingClassify x <- xs]- ,H.resolveHints $ [Right x | SettingMatchExp x <- xs] ++ map Left enumerate)+ ,H.resolveHints ([Right x | SettingMatchExp x <- xs] ++ map Left enumerate)+ <> mempty { hintModule = Restrict.restrictHint . (xs++)}+ ) -- | Given a way of classifying results, and a 'Hint', apply to a set of modules generating a list of 'Idea's.@@ -141,7 +145,7 @@ -- -- > (filename, (startLine, startCol), (endLine, endCol)) ----- Following the GHC API, he end column is the column /after/ the end of the error.+-- Following the GHC API, end column is the column /after/ the end of the error. -- Lines and columns are 1-based. Returns 'Nothing' if there is no helpful location information. unpackSrcSpan :: SrcSpan -> Maybe (FilePath, (Int, Int), (Int, Int)) unpackSrcSpan (RealSrcSpan x _) = Just
src/Refact.hs view
@@ -1,14 +1,16 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} module Refact ( substVars , toRefactSrcSpan- , toSS+ , toSS, toSSA, toSSAnc , checkRefactor, refactorPath, runRefactoring ) where import Control.Exception.Extra import Control.Monad+import Data.List.NonEmpty qualified as NE import Data.Maybe import Data.Version.Extra import GHC.LanguageExtensions.Type@@ -17,10 +19,13 @@ import System.Exit import System.IO.Extra import System.Process.Extra-import qualified Refact.Types as R+import Refact.Types qualified as R -import qualified GHC.Types.SrcLoc as GHC+import GHC.Types.SrcLoc qualified as GHC+import GHC.Parser.Annotation qualified as GHC +import GHC.Util.SrcLoc (getAncLoc)+ substVars :: [String] substVars = [letter : number | number <- "" : map show [0..], letter <- ['a'..'z']] @@ -39,6 +44,12 @@ toSS :: GHC.Located a -> R.SrcSpan toSS = toRefactSrcSpan . GHC.getLoc +toSSA :: GHC.GenLocated (GHC.EpAnn a) e -> R.SrcSpan+toSSA = toRefactSrcSpan . GHC.getLocA++toSSAnc :: GHC.GenLocated GHC.NoCommentsLocation e -> R.SrcSpan+toSSAnc = toRefactSrcSpan . getAncLoc+ checkRefactor :: Maybe FilePath -> IO FilePath checkRefactor = refactorPath >=> either errorIO pure @@ -48,7 +59,7 @@ mexc <- findExecutable excPath case mexc of Just exc -> do- ver <- readVersion . tail <$> readProcess exc ["--version"] ""+ ver <- readVersion . NE.tail . NE.fromList <$> readProcess exc ["--version"] "" pure $ if ver >= minRefactorVersion then Right exc else Left $ "Your version of refactor is too old, please install apply-refact "
src/Report.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE RecordWildCards #-} module Report(writeReport) where@@ -5,14 +6,14 @@ import Idea import Data.Tuple.Extra import Data.List.Extra-import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty qualified as NE import Data.Maybe import Data.Version import Timing import Paths_hlint import HsColour import EmbedData-import qualified GHC.Util as GHC+import GHC.Util qualified as GHC writeTemplate :: FilePath -> [(String,[String])] -> FilePath -> IO ()
+ src/SARIF.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{- |+Description: Formats hlint ideas in the Statis Analysis Results Interchange Format (SARIF).+License: BSD-3-Clause++Supports the conversion of a list of HLint 'Idea's into SARIF.++SARIF (Static Analysis Results Interchange Format) is an open interchange format+for storing results from static analyses.+-}+module SARIF ( printIdeas+ , showIdeas+ , toJSONEncoding+ -- * See also+ --+ -- $references+ ) where++import Data.Aeson hiding (Error)+import Data.Aeson.Encoding+import Data.ByteString.Lazy (ByteString)+import Data.ByteString.Lazy qualified as B+import Data.Text.Lazy (Text)+import Data.Version (showVersion)+import GHC.Util+import Idea+import Paths_hlint (version)++-- | Print the given ideas to standard output.+--+-- For example:+--+-- >>> hlint ["src"] >>= printIdeas+--+-- For printing ideas in SARIF without dependent modules+-- having to import "Data.Aeson" or "Data.ByteString.Lazy".+printIdeas :: [Idea] -> IO ()+printIdeas = B.putStr . showIdeas++-- | Format the given ideas in SARIF.+--+-- For converting ideas to SARIF without dependent modules+-- having to import "Data.Aeson".+showIdeas :: [Idea] -> ByteString+showIdeas = encodingToLazyByteString . toJSONEncoding++-- | Converts the given ideas to a "Data.Aeson" encoding in SARIF.+toJSONEncoding :: [Idea] -> Encoding+toJSONEncoding = pairs . sarif++-- | Converts the given object to a top-level @sarifLog@ object.+--+-- See section 3.13 "sarifLog object", SARIF specification.+sarif :: [Idea] -> Series+sarif ideas =+ pair "version" (lazyText "2.1.0") <>+ pair "$schema" (lazyText schemaURI) <>+ pair "runs" runs+ where runs = list pairs [ pair "tool" (pairs tool) <>+ pair "results" (list (pairs . toResult) ideas) ]++-- | A @tool@ object describing what created the output.+--+-- Obviously, it will describe that HLint created the output.+--+-- See section 3.18 "tool object", SARIF specification.+tool :: Series+tool = pair "driver" $ pairs $+ pair "name" (lazyText "hlint") <>+ pair "version" (string $ showVersion version) <>+ pair "informationUri" (lazyText hlintURI)++-- | Converts a given idea into a @result@ object.+--+-- It will describe the hint, the severity, suggestions for fixes, etc.+--+-- See section 3.27 "result object", SARIF specification.+toResult :: Idea -> Series+toResult idea@Idea{..} =+ pair "message" (pairs $ pair "text" $ string $ show idea) <>+ pair "level" (lazyText $ showSeverity ideaSeverity) <>+ pair "locations" (list (pairs . toLocation) [idea]) <>+ pair "fixes" (list (pairs . toFix) [idea]) <>+ -- Use 'ideaHint' as the rule identifier.+ --+ -- "ruleId" is supposed to a stable, opaque identifier.+ -- 'ideaHint' is not opaque, nor is it quite guaranteed to be stable,+ -- but they will usually be stable enough, and disabling a hint is+ -- based on the name in 'ideaHint'.+ --+ -- Most importantly, there is no requirement that "ruleId"+ -- be a /unique/ identifier.+ pair "ruleId" (string ideaHint)++-- | Convert HLint severity to SARIF level.+--+-- See section 3.58.6 "level property", SARIF specification.+showSeverity :: Severity -> Text+showSeverity Error = "error"+showSeverity Warning = "warning"+showSeverity Suggestion = "note"+showSeverity Ignore = "none"++-- | Converts the location information in a given idea to a @location@ object.+--+-- See section 3.28 "location object", SARIF specification.+toLocation :: Idea -> Series+toLocation idea@Idea{ideaSpan=SrcSpan{..}, ..} =+ physicalLocation <> logicalLocations ideaModule ideaDecl+ where physicalLocation = pair "physicalLocation" $ pairs $+ pair "artifactLocation"+ (pairs $ pair "uri" (string srcSpanFilename)) <>+ pair "region" (pairs $ toRegion idea)++ logicalLocations [mod] [decl] = pair "logicalLocations" $+ list pairs [ pair "name" (string decl) <>+ pair "fullyQualifiedName" (string $ mod ++ "." ++ decl) ]+ -- It would be nice to include whether it is a function or type+ -- in the "kind" field, but we do not have that information.++ -- If the lists are empty, then there is obviously no logical location.+ -- Logical location is still omitted when the lists are not singleton,+ -- because the associations between modules and declarations are+ -- not clear.+ logicalLocations _ _ = mempty++-- | Converts a given idea to a @fix@ object.+--+-- It will suggest how code can be improved to deal with an issue.+-- This includes the file to be changed and how to change it.+--+-- See section 3.55 "fix object", SARIF specification.+toFix :: Idea -> Series+toFix idea@Idea{..} =+ pair "description" (pairs $ pair "text" $ string ideaHint) <>+ pair "artifactChanges" (list (pairs . toChange) [idea])++-- | Converts a given idea to a @artifactChange@ object.+--+-- It will describe the details as to how the code can be changed.+-- I.e., the text to remove and what it should be replaced with.+--+-- See section 3.56 "artifactChange object", SARIF specification.+toChange :: Idea -> Series+toChange idea@Idea{ideaSpan=SrcSpan{..}, ..} =+ pair "artifactLocation" (pairs uri) <>+ pair "replacements" (list pairs [deleted <> inserted])+ where uri = pair "uri" $ string srcSpanFilename+ deleted = pair "deletedRegion" $ pairs $ toRegion idea+ inserted = maybe mempty insertedContent ideaTo+ insertedContent = pair "insertedContent" . pairs . pair "text" . string++-- | Converts the source span in an idea to a SARIF region.+--+-- See 3.30 "region object", SARIF specification.+toRegion :: Idea -> Series+toRegion Idea{ideaSpan=SrcSpan{..}, ..} =+ pair "startLine" (int srcSpanStartLine') <>+ pair "startColumn" (int srcSpanStartColumn) <>+ pair "endLine" (int srcSpanEndLine') <>+ pair "endColumn" (int srcSpanEndColumn)++-- | URI to SARIF schema definition.+schemaURI :: Text+schemaURI = "https://raw.githubusercontent.com/" <>+ "oasis-tcs/sarif-spec/master/Schemata/sarif-schema-2.1.0.json"++-- | URI to HLint home page.+hlintURI :: Text+hlintURI = "https://github.com/ndmitchell/hlint"++-- $references+--+-- * [SARIF Tutorials](https://github.com/microsoft/sarif-tutorials)+-- * [Static Analysis Results Interchange Format](https://docs.oasis-open.org/sarif/sarif/v2.1.0/cs01/sarif-v2.1.0-cs01.html), version 2.1.0
src/Summary.hs view
@@ -1,10 +1,15 @@-{-# LANGUAGE RecordWildCards, TupleSections #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# 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 Data.Map qualified as Map import Control.Monad.Extra import System.FilePath+import Data.List.NonEmpty qualified as NE import Data.List.Extra import System.Directory @@ -14,73 +19,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 (NE.head . NE.fromList) . 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 +150,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 (NE.head (NE.fromList 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 =
src/Test/Annotations.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE CPP, PatternGuards, RecordWildCards, ViewPatterns #-} -- | Check the <TEST> annotations within source and hint files.@@ -17,7 +18,7 @@ import System.FilePath import System.IO.Extra import GHC.All-import qualified Data.ByteString.Char8 as BS+import Data.ByteString.Char8 qualified as BS import Config.Type import Idea@@ -123,7 +124,10 @@ open line | "<TEST>" `isPrefixOf` line = let suffix = dropPrefix "<TEST>" line- config = decodeEither' $ BS.pack suffix+ config =+ if isBuiltinYaml file+ then mapRight getConfigYamlBuiltin $ decodeEither' $ BS.pack suffix+ else mapRight getConfigYamlUser $ decodeEither' $ BS.pack suffix in case config of Left err -> Just [] Right config -> Just $ settingsFromConfigYaml [config]@@ -160,7 +164,7 @@ testRefactor Nothing _ _ = pure [] -- Skip refactoring test if there is no hint. testRefactor _ Nothing _ = pure []--- Skip refactoring test if the hint has no suggestion (such as "Parse error" or "Avoid restricted fuction").+-- Skip refactoring test if the hint has no suggestion (such as "Parse error" or "Avoid restricted function"). testRefactor _ (Just idea) _ | isNothing (ideaTo idea) = pure [] -- Skip refactoring test if the hint does not support refactoring. testRefactor _ (Just idea) _ | null (ideaRefactoring idea) = pure []
src/Test/InputOutput.hs view
@@ -17,6 +17,8 @@ import System.Exit import System.IO.Extra import Prelude+import Data.Version (showVersion)+import Paths_hlint (version) import Test.Util @@ -48,6 +50,8 @@ where z = InputOutput "unknown" [] [] "" Nothing interest x = any (`isPrefixOf` x) ["----","FILE","RUN","OUTPUT","EXIT"]+ outputTemplateVars = [ ("__VERSION__", showVersion version) ]+ substituteTemplateVars = mconcatMap (uncurry replace) outputTemplateVars f io ((stripPrefix "RUN " -> Just flags):xs) = f io{run = splitArgs flags} xs f io ((stripPrefix "EXIT " -> Just code):xs) = f io{exit = Just $ let i = read code in if i == 0 then ExitSuccess else ExitFailure i} xs@@ -57,7 +61,7 @@ f io [] = [io | io /= z] f io (x:xs) = error $ "Unknown test item, " ++ x - g = first (reverse . dropWhile null . reverse) . break interest+ g = first (fmap substituteTemplateVars . reverse . dropWhile null . reverse) . break interest ---------------------------------------------------------------------
src/Timing.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} module Timing( timed, timedIO,@@ -5,7 +6,7 @@ printTimings ) where -import qualified Data.HashMap.Strict as Map+import Data.HashMap.Strict qualified as Map import Control.Exception import Data.IORef.Extra import Data.Tuple.Extra
src/Util.hs view
@@ -4,7 +4,7 @@ forceList, gzip, universeParentBi, exitMessage, exitMessageImpure,- getContentsUTF8+ getContentsUTF8, wildcardMatch ) where import System.Exit@@ -13,6 +13,8 @@ import Unsafe.Coerce import Data.Data import Data.Generics.Uniplate.DataOnly+import System.FilePattern+import Data.List.Extra ---------------------------------------------------------------------@@ -64,3 +66,23 @@ universeParentBi :: (Data a, Data b) => a -> [(Maybe b, b)] universeParentBi = concatMap universeParent . childrenBi+++---------------------------------------------------------------------+-- SYSTEM.FILEPATTERN++-- | Returns true if the pattern matches the string. For example:+--+-- >>> let isSpec = wildcardMatch "**.*Spec"+-- >>> isSpec "Example"+-- False+-- >>> isSpec "ExampleSpec"+-- True+-- >>> isSpec "Namespaced.ExampleSpec"+-- True+-- >>> isSpec "Deeply.Nested.ExampleSpec"+-- True+--+-- See this issue for details: <https://github.com/ndmitchell/hlint/issues/402>.+wildcardMatch :: FilePattern -> String -> Bool+wildcardMatch p m = let f = replace "." "/" in f p ?== f m
tests/cpp.test view
@@ -44,8 +44,8 @@ main = undefined EXIT 1 OUTPUT-tests/cpp-ext-enable.hs:1:1: Error: Parse error: Unsupported extension: Foo-+tests/cpp-ext-enable.hs:1:1: Error: Parse error: tests/cpp-ext-enable.hs:3:14: error: [GHC-46537]+ Unsupported extension: Foo Found: {-# LANGUAGE CPP #-} @@ -53,7 +53,7 @@ main = undefined -1 hint+1 error --------------------------------------------------------------------- RUN tests/cpp-ext-disable.hs@@ -129,3 +129,39 @@ #endif OUTPUT No hints++---------------------------------------------------------------------+RUN tests/cpp-file5.hs+FILE tests/cpp-file5.hs+{-# LANGUAGE CPP #-}+main =+#if __GLASGOW_HASKELL__ > 800+ print __GLASGOW_HASKELL__+#else+ putStrLn $ show __GLASGOW_HASKELL__+#endif+OUTPUT+tests/cpp-file5.hs:1:1-20: Warning: Avoid restricted extensions+Found:+ {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN --cpp-define "__GLASGOW_HASKELL__=123" tests/cpp-file6.hs+FILE tests/cpp-file6.hs+{-# LANGUAGE CPP #-}+main =+#if __GLASGOW_HASKELL__ == 123+ print __GLASGOW_HASKELL__+#else+ putStrLn $ show __GLASGOW_HASKELL__+#endif+OUTPUT+tests/cpp-file6.hs:1:1-20: Warning: Avoid restricted extensions+Found:+ {-# LANGUAGE CPP #-}+Note: may break the code++1 hint
+ tests/do-block.test view
@@ -0,0 +1,17 @@+---------------------------------------------------------------------+RUN tests/do-block.hs --hint=data/do-block.yaml+FILE tests/do-block.hs+h x = case f x of+ Just n -> g n+ Nothing -> Nothing+OUTPUT+tests/do-block.hs:(1,7)-(3,20): Warning: Redundant Nothing+Found:+ case f x of+ Just n -> g n+ Nothing -> Nothing+Perhaps:+ do n <- f x+ g n++1 hint
+ tests/flag-ignore-suggestions.test view
@@ -0,0 +1,38 @@+---------------------------------------------------------------------+RUN tests/flag-ignore-suggestions-1.hs --ignore-suggestions+FILE tests/flag-ignore-suggestions-1.hs+main = map f $ map g xs+OUTPUT+No hints++EXIT 0+---------------------------------------------------------------------+RUN tests/flag-ignore-suggestions-2.hs --ignore-suggestions+FILE tests/flag-ignore-suggestions-2.hs+foo = (+1)+bar x = foo x+main = map f $ map g xs+OUTPUT+tests/flag-ignore-suggestions-2.hs:2:1-13: Warning: Eta reduce+Found:+ bar x = foo x+Perhaps:+ bar = foo++1 hint++EXIT 1+---------------------------------------------------------------------+RUN tests/flag-ignore-suggestions-3.hs --ignore-suggestions --show+FILE tests/flag-ignore-suggestions-3.hs+main = map f $ map g xs+OUTPUT+tests/flag-ignore-suggestions-3.hs:1:8-23: Suggestion: Use map once+Found:+ map f $ map g xs+Perhaps:+ map (f . g) xs++1 hint++EXIT 1
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/hint.test view
@@ -45,9 +45,9 @@ OUTPUT tests/brackets.hs:1:8-49: Warning: Use fromMaybe Found:- if isNothing x then (-1.0) else fromJust x+ if isNothing x then (- 1.0) else fromJust x Perhaps:- fromMaybe (-1.0) x+ fromMaybe (- 1.0) x 1 hint @@ -98,6 +98,82 @@ Note: Custom message 1 hint++---------------------------------------------------------------------+RUN tests/restricted-badidents-bad.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-badidents-bad.lhs+> import Restricted.Module.BadIdents (bad)+OUTPUT+tests/restricted-badidents-bad.lhs:1:3-42: Warning: Avoid restricted identifiers+Found:+ import Restricted.Module.BadIdents ( bad )+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN tests/restricted-badidents-multibad.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-badidents-multibad.lhs+> import Restricted.Module.BadIdents (bad, good)+OUTPUT+tests/restricted-badidents-multibad.lhs:1:3-48: Warning: Avoid restricted identifiers+Found:+ import Restricted.Module.BadIdents ( bad, good )+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN tests/restricted-badidents-valid.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-badidents-valid.lhs+> import Restricted.Module.BadIdents (good)+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/restricted-badidents-universal.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-badidents-universal.lhs+> import Restricted.Module.BadIdents+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/restricted-onlyidents-bad.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-onlyidents-bad.lhs+> import Restricted.Module.OnlyIdents (bad)+OUTPUT+tests/restricted-onlyidents-bad.lhs:1:3-43: Warning: Avoid restricted identifiers+Found:+ import Restricted.Module.OnlyIdents ( bad )+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN tests/restricted-onlyidents-multibad.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-onlyidents-multibad.lhs+> import Restricted.Module.OnlyIdents (bad, good)+OUTPUT+tests/restricted-onlyidents-multibad.lhs:1:3-49: Warning: Avoid restricted identifiers+Found:+ import Restricted.Module.OnlyIdents ( bad, good )+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN tests/restricted-onlyidents-valid.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-onlyidents-valid.lhs+> import Restricted.Module.OnlyIdents (good)+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/restricted-onlyidents-universal.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-onlyidents-universal.lhs+> import Restricted.Module.OnlyIdents+OUTPUT+No hints --------------------------------------------------------------------- RUN tests/restricted-function.lhs --hint=data/test-restrict.yaml
+ tests/hintrule-implies-classify.test view
@@ -0,0 +1,12 @@+---------------------------------------------------------------------+RUN tests/hintrule-implies-classify.hs --hint=data/hintrule-implies-classify.yaml+FILE tests/hintrule-implies-classify.hs+x = mapM print [1, 2, 3]+OUTPUT+tests/hintrule-implies-classify.hs:1:5-8: Warning: Use traverse+Found:+ mapM+Perhaps:+ traverse++1 hint
+ tests/import_style.test view
@@ -0,0 +1,129 @@+---------------------------------------------------------------------+RUN tests/importStyle-1.hs --hint=data/import_style.yaml+FILE tests/importStyle-1.hs+import HypotheticalModule1+import HypotheticalModule2+import HypotheticalModule3+import qualified HypotheticalModule3.SomeModule+import HypotheticalModule3.SomeModule qualified+import qualified HypotheticalModule3.OtherSubModule+OUTPUT+tests/importStyle-1.hs:1:1-26: Warning: Avoid restricted alias+Found:+ import HypotheticalModule1+Perhaps:+ import HypotheticalModule1 as HM1+Note: may break the code++tests/importStyle-1.hs:2:1-26: Warning: HypotheticalModule2 should be imported qualified or with an explicit import list+Found:+ import HypotheticalModule2+Perhaps:+ import qualified HypotheticalModule2+Note: may break the code++tests/importStyle-1.hs:3:1-26: Warning: HypotheticalModule3 should be imported qualified+Found:+ import HypotheticalModule3+Perhaps:+ import qualified HypotheticalModule3+Note: may break the code++tests/importStyle-1.hs:4:1-47: Warning: HypotheticalModule3.SomeModule should be imported unqualified+Found:+ import qualified HypotheticalModule3.SomeModule+Perhaps:+ import HypotheticalModule3.SomeModule+Note: may break the code++tests/importStyle-1.hs:5:1-47: Warning: HypotheticalModule3.SomeModule should be imported unqualified+Found:+ import HypotheticalModule3.SomeModule qualified+Perhaps:+ import HypotheticalModule3.SomeModule+Note: may break the code++tests/importStyle-1.hs:6:1-51: Warning: HypotheticalModule3.OtherSubModule should be imported post-qualified or unqualified+Found:+ import qualified HypotheticalModule3.OtherSubModule+Perhaps:+ import HypotheticalModule3.OtherSubModule qualified+Note: may break the code++6 hints++---------------------------------------------------------------------+RUN tests/importStyle-2.hs --hint=data/import_style.yaml+FILE tests/importStyle-2.hs+import HypotheticalModule1 as HM1+import qualified HypotheticalModule2+import HypotheticalModule2 (a, b, c, d)+import qualified HypotheticalModule3+import HypotheticalModule3.SomeModule+import HypotheticalModule3.OtherSubModule qualified+import HypotheticalModule3.OtherSubModule+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/importStyle-postqual-pos.hs --hint=data/import_style.yaml -XImportQualifiedPost+FILE tests/importStyle-postqual-pos.hs+import HypotheticalModule1 qualified as HM1+import HypotheticalModule2 qualified+import HypotheticalModule2 qualified as Arbitrary+import HypotheticalModule3 qualified+import HypotheticalModule3 qualified as Arbitrary+import HypotheticalModule4 qualified as HM4+import HypotheticalModule5 qualified+import HypotheticalModule5 qualified as HM5+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/importStyle-postqual-neg.hs --hint=data/import_style.yaml -XImportQualifiedPost+FILE tests/importStyle-postqual-neg.hs+import HypotheticalModule1 qualified+import qualified HypotheticalModule4+import qualified HypotheticalModule4 as Verbotten+import qualified HypotheticalModule4 as HM4+import HypotheticalModule5 as HM5+import qualified HypotheticalModule5++OUTPUT+tests/importStyle-postqual-neg.hs:1:1-36: Warning: Avoid restricted alias+Found:+ import HypotheticalModule1 qualified+Perhaps:+ import HypotheticalModule1 qualified as HM1+Note: may break the code++tests/importStyle-postqual-neg.hs:2:1-36: Warning: Avoid restricted alias+Found:+ import qualified HypotheticalModule4+Perhaps:+ import qualified HypotheticalModule4 as HM4+Note: may break the code++tests/importStyle-postqual-neg.hs:3:1-49: Warning: Avoid restricted alias+Found:+ import qualified HypotheticalModule4 as Verbotten+Perhaps:+ import qualified HypotheticalModule4 as HM4+Note: may break the code++tests/importStyle-postqual-neg.hs:5:1-33: Warning: HypotheticalModule5 should be imported post-qualified+Found:+ import HypotheticalModule5 as HM5+Perhaps:+ import HypotheticalModule5 qualified as HM5+Note: may break the code++tests/importStyle-postqual-neg.hs:6:1-36: Warning: HypotheticalModule5 should be imported post-qualified+Found:+ import qualified HypotheticalModule5+Perhaps:+ import HypotheticalModule5 qualified+Note: may break the code++5 hints+---------------------------------------------------------------------
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/lhs.test view
@@ -31,7 +31,7 @@ > -1 hint+1 error --------------------------------------------------------------------- RUN tests/lhs-first-line.lhs
+ tests/no_explicit_cpp.test view
@@ -0,0 +1,17 @@+---------------------------------------------------------------------+RUN tests/NoExplicitCpp.hs -XHaskell2010+FILE tests/NoExplicitCpp.hs+-- We expect C-preprocessing despite `CPP` not being in the+-- enabled extensions implied by the command line. See issue+-- https://github.com/ndmitchell/hlint/issues/1360.+{-# LANGUAGE CPP #-}+#if 1+hlint = __HLINT__+#endif+OUTPUT+tests/NoExplicitCpp.hs:4:1-20: Warning: Avoid restricted extensions+Found:+ {-# LANGUAGE CPP #-}+Note: may break the code++1 hint
tests/parse-error.test view
@@ -18,16 +18,16 @@ > where -1 hint+1 error --------------------------------------------------------------------- RUN tests/ignore-parse-error3.hs FILE tests/ignore-parse-error3.hs {-# LANGUAGE InvalidExtension #-} OUTPUT-tests/ignore-parse-error3.hs:1:1: Error: Parse error: Unsupported extension: InvalidExtension-+tests/ignore-parse-error3.hs:1:1: Error: Parse error: tests/ignore-parse-error3.hs:1:14: error: [GHC-46537]+ Unsupported extension: InvalidExtension Found: {-# LANGUAGE InvalidExtension #-} -1 hint+1 error
+ tests/sarif.test view
@@ -0,0 +1,38 @@+---------------------------------------------------------------------+RUN tests/sarif-none.hs --sarif+FILE tests/sarif-none.hs+foo = (+1)+OUTPUT+{"version":"2.1.0","$schema":"https://raw.githubusercontent.com/oasis-tcs/sarif-spec/master/Schemata/sarif-schema-2.1.0.json","runs":[{"tool":{"driver":{"name":"hlint","version":"__VERSION__","informationUri":"https://github.com/ndmitchell/hlint"}},"results":[]}]}++---------------------------------------------------------------------+RUN tests/sarif-one.hs --sarif+FILE tests/sarif-one.hs+foo = (+1)+bar x = foo x+OUTPUT+{"version":"2.1.0","$schema":"https://raw.githubusercontent.com/oasis-tcs/sarif-spec/master/Schemata/sarif-schema-2.1.0.json","runs":[{"tool":{"driver":{"name":"hlint","version":"__VERSION__","informationUri":"https://github.com/ndmitchell/hlint"}},"results":[{"message":{"text":"tests/sarif-one.hs:2:1-13: Warning: Eta reduce\nFound:\n bar x = foo x\nPerhaps:\n bar = foo\n"},"level":"warning","locations":[{"physicalLocation":{"artifactLocation":{"uri":"tests/sarif-one.hs"},"region":{"startLine":2,"startColumn":1,"endLine":2,"endColumn":14}},"logicalLocations":[{"name":"bar","fullyQualifiedName":"Main.bar"}]}],"fixes":[{"description":{"text":"Eta reduce"},"artifactChanges":[{"artifactLocation":{"uri":"tests/sarif-one.hs"},"replacements":[{"deletedRegion":{"startLine":2,"startColumn":1,"endLine":2,"endColumn":14},"insertedContent":{"text":"bar = foo"}}]}]}],"ruleId":"Eta reduce"}]}]}++---------------------------------------------------------------------+RUN tests/sarif-two.hs --sarif+FILE tests/sarif-two.hs+foo = (+1)+bar x = foo x+baz = getLine >>= pure . upper+OUTPUT+{"version":"2.1.0","$schema":"https://raw.githubusercontent.com/oasis-tcs/sarif-spec/master/Schemata/sarif-schema-2.1.0.json","runs":[{"tool":{"driver":{"name":"hlint","version":"__VERSION__","informationUri":"https://github.com/ndmitchell/hlint"}},"results":[{"message":{"text":"tests/sarif-two.hs:2:1-13: Warning: Eta reduce\nFound:\n bar x = foo x\nPerhaps:\n bar = foo\n"},"level":"warning","locations":[{"physicalLocation":{"artifactLocation":{"uri":"tests/sarif-two.hs"},"region":{"startLine":2,"startColumn":1,"endLine":2,"endColumn":14}},"logicalLocations":[{"name":"bar","fullyQualifiedName":"Main.bar"}]}],"fixes":[{"description":{"text":"Eta reduce"},"artifactChanges":[{"artifactLocation":{"uri":"tests/sarif-two.hs"},"replacements":[{"deletedRegion":{"startLine":2,"startColumn":1,"endLine":2,"endColumn":14},"insertedContent":{"text":"bar = foo"}}]}]}],"ruleId":"Eta reduce"},{"message":{"text":"tests/sarif-two.hs:3:7-30: Suggestion: Use <&>\nFound:\n getLine >>= pure . upper\nPerhaps:\n getLine Data.Functor.<&> upper\n"},"level":"note","locations":[{"physicalLocation":{"artifactLocation":{"uri":"tests/sarif-two.hs"},"region":{"startLine":3,"startColumn":7,"endLine":3,"endColumn":31}},"logicalLocations":[{"name":"baz","fullyQualifiedName":"Main.baz"}]}],"fixes":[{"description":{"text":"Use <&>"},"artifactChanges":[{"artifactLocation":{"uri":"tests/sarif-two.hs"},"replacements":[{"deletedRegion":{"startLine":3,"startColumn":7,"endLine":3,"endColumn":31},"insertedContent":{"text":"getLine Data.Functor.<&> upper"}}]}]}],"ruleId":"Use <&>"}]}]}++---------------------------------------------------------------------+RUN tests/sarif-parse-error.hs --sarif+FILE tests/sarif-parse-error.hs+@+OUTPUT+{"version":"2.1.0","$schema":"https://raw.githubusercontent.com/oasis-tcs/sarif-spec/master/Schemata/sarif-schema-2.1.0.json","runs":[{"tool":{"driver":{"name":"hlint","version":"__VERSION__","informationUri":"https://github.com/ndmitchell/hlint"}},"results":[{"message":{"text":"tests/sarif-parse-error.hs:1:1: Error: Parse error: on input `@'\nFound:\n > @\n"},"level":"error","locations":[{"physicalLocation":{"artifactLocation":{"uri":"tests/sarif-parse-error.hs"},"region":{"startLine":1,"startColumn":1,"endLine":1,"endColumn":2}}}],"fixes":[{"description":{"text":"Parse error: on input `@'"},"artifactChanges":[{"artifactLocation":{"uri":"tests/sarif-parse-error.hs"},"replacements":[{"deletedRegion":{"startLine":1,"startColumn":1,"endLine":1,"endColumn":2}}]}]}],"ruleId":"Parse error: on input `@'"}]}]}++---------------------------------------------------------------------+RUN tests/sarif-note.hs --sarif+FILE tests/sarif-note.hs+foo = any (a ==)+bar = foldl (&&) True+OUTPUT+{"version":"2.1.0","$schema":"https://raw.githubusercontent.com/oasis-tcs/sarif-spec/master/Schemata/sarif-schema-2.1.0.json","runs":[{"tool":{"driver":{"name":"hlint","version":"__VERSION__","informationUri":"https://github.com/ndmitchell/hlint"}},"results":[{"message":{"text":"tests/sarif-note.hs:1:7-16: Warning: Use elem\nFound:\n any (a ==)\nPerhaps:\n elem a\n"},"level":"warning","locations":[{"physicalLocation":{"artifactLocation":{"uri":"tests/sarif-note.hs"},"region":{"startLine":1,"startColumn":7,"endLine":1,"endColumn":17}},"logicalLocations":[{"name":"foo","fullyQualifiedName":"Main.foo"}]}],"fixes":[{"description":{"text":"Use elem"},"artifactChanges":[{"artifactLocation":{"uri":"tests/sarif-note.hs"},"replacements":[{"deletedRegion":{"startLine":1,"startColumn":7,"endLine":1,"endColumn":17},"insertedContent":{"text":"elem a"}}]}]}],"ruleId":"Use elem"},{"message":{"text":"tests/sarif-note.hs:2:7-21: Warning: Use and\nFound:\n foldl (&&) True\nPerhaps:\n and\nNote: increases laziness\n"},"level":"warning","locations":[{"physicalLocation":{"artifactLocation":{"uri":"tests/sarif-note.hs"},"region":{"startLine":2,"startColumn":7,"endLine":2,"endColumn":22}},"logicalLocations":[{"name":"bar","fullyQualifiedName":"Main.bar"}]}],"fixes":[{"description":{"text":"Use and"},"artifactChanges":[{"artifactLocation":{"uri":"tests/sarif-note.hs"},"replacements":[{"deletedRegion":{"startLine":2,"startColumn":7,"endLine":2,"endColumn":22},"insertedContent":{"text":"and"}}]}]}],"ruleId":"Use and"}]}]}
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"}])] ---------------------------------------------------------------------@@ -37,7 +37,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-} OUTPUT-[("tests/serialise-four.hs:1:1-20: Warning: Use fewer LANGUAGE pragmas\nFound:\n {-# LANGUAGE CPP #-}\n {-# LANGUAGE CPP #-}\nPerhaps:\n {-# LANGUAGE CPP #-}\n",[ModifyComment {pos = SrcSpan {startLine = 1, startCol = 1, endLine = 1, endCol = 21}, newComment = "{-# LANGUAGE CPP #-}"},ModifyComment {pos = SrcSpan {startLine = 2, startCol = 1, endLine = 2, endCol = 21}, newComment = ""}])]+[("tests/serialise-four.hs:2:1-20: Warning: Use fewer LANGUAGE pragmas\nFound:\n {-# LANGUAGE CPP #-}\n {-# LANGUAGE CPP #-}\nPerhaps:\n {-# LANGUAGE CPP #-}\n",[ModifyComment {pos = SrcSpan {startLine = 2, startCol = 1, endLine = 2, endCol = 21}, newComment = "{-# LANGUAGE CPP #-}"},ModifyComment {pos = SrcSpan {startLine = 1, startCol = 1, endLine = 1, endCol = 21}, newComment = ""}])] ---------------------------------------------------------------------
− tests/wildcard.test
@@ -1,45 +0,0 @@-----------------------------------------------------------------------RUN tests/wildcard-1.hs --hint=data/wildcard.yaml-FILE tests/wildcard-1.hs-module SpecNoMatch where-main = print $ (\ _ -> 'a') ()-OUTPUT-tests/wildcard-1.hs:2:17-26: Suggestion: Use const-Found:- \ _ -> 'a'-Perhaps:- const 'a'--1 hint------------------------------------------------------------------------RUN tests/wildcard-2.hs --hint=data/wildcard.yaml-FILE tests/wildcard-2.hs-module Spec where-main = print $ (\ _ -> 'a') ()-OUTPUT-No hints------------------------------------------------------------------------RUN tests/wildcard-3.hs --hint=data/wildcard.yaml-FILE tests/wildcard-3.hs-module PrefixedSpec where-main = print $ (\ _ -> 'a') ()-OUTPUT-No hints------------------------------------------------------------------------RUN tests/wildcard-4.hs --hint=data/wildcard.yaml-FILE tests/wildcard-4.hs-module Namespaced.Spec where-main = print $ (\ _ -> 'a') ()-OUTPUT-No hints------------------------------------------------------------------------RUN tests/wildcard-5.hs --hint=data/wildcard.yaml-FILE tests/wildcard-5.hs-module Deeply.Nested.Spec where-main = print $ (\ _ -> 'a') ()-OUTPUT-No hints
+ tests/wildcards.test view
@@ -0,0 +1,816 @@+----+RUN tests/wildcards-a.hs --hint=data/wildcards.yaml+FILE tests/wildcards-a.hs+import A as Z+OUTPUT+tests/wildcards-a.hs:1:1-13: Warning: Avoid restricted alias+Found:+ import A as Z+Perhaps:+ import A as A+Note: may break the code++1 hint++----+RUN tests/wildcards-xa.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xa.hs+import XA as Z+OUTPUT+No hints++----+RUN tests/wildcards-x-a.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-a.hs+import X.A as Z+OUTPUT+No hints++----+RUN tests/wildcards-x-y-a.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-a.hs+import X.Y.A as Z+OUTPUT+No hints++----+RUN tests/wildcards-b.hs --hint=data/wildcards.yaml+FILE tests/wildcards-b.hs+import B as Z+OUTPUT+tests/wildcards-b.hs:1:1-13: Warning: Avoid restricted alias+Found:+ import B as Z+Perhaps:+ import B as B+Note: may break the code++1 hint++----+RUN tests/wildcards-xb.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xb.hs+import XB as Z+OUTPUT+tests/wildcards-xb.hs:1:1-14: Warning: Avoid restricted alias+Found:+ import XB as Z+Perhaps:+ import XB as B+Note: may break the code++1 hint++----+RUN tests/wildcards-x-b.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-b.hs+import X.B as Z+OUTPUT+No hints++----+RUN tests/wildcards-x-y-b.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-b.hs+import X.Y.B as Z+OUTPUT+No hints++----+RUN tests/wildcards-c.hs --hint=data/wildcards.yaml+FILE tests/wildcards-c.hs+import C as Z+OUTPUT+tests/wildcards-c.hs:1:1-13: Warning: Avoid restricted alias+Found:+ import C as Z+Perhaps:+ import C as C+Note: may break the code++1 hint++----+RUN tests/wildcards-xc.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xc.hs+import XC as Z+OUTPUT+No hints++----+RUN tests/wildcards-x-c.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-c.hs+import X.C as Z+OUTPUT+tests/wildcards-x-c.hs:1:1-15: Warning: Avoid restricted alias+Found:+ import X.C as Z+Perhaps:+ import X.C as C+Note: may break the code++1 hint++----+RUN tests/wildcards-x-y-c.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-c.hs+import X.Y.C as Z+OUTPUT+tests/wildcards-x-y-c.hs:1:1-17: Warning: Avoid restricted alias+Found:+ import X.Y.C as Z+Perhaps:+ import X.Y.C as C+Note: may break the code++1 hint++----+RUN tests/wildcards-d.hs --hint=data/wildcards.yaml+FILE tests/wildcards-d.hs+import D as Z+OUTPUT+tests/wildcards-d.hs:1:1-13: Warning: Avoid restricted alias+Found:+ import D as Z+Perhaps:+ import D as D+Note: may break the code++1 hint++----+RUN tests/wildcards-xd.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xd.hs+import XD as Z+OUTPUT+tests/wildcards-xd.hs:1:1-14: Warning: Avoid restricted alias+Found:+ import XD as Z+Perhaps:+ import XD as D+Note: may break the code++1 hint++----+RUN tests/wildcards-x-d.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-d.hs+import X.D as Z+OUTPUT+tests/wildcards-x-d.hs:1:1-15: Warning: Avoid restricted alias+Found:+ import X.D as Z+Perhaps:+ import X.D as D+Note: may break the code++1 hint++----+RUN tests/wildcards-x-y-d.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-d.hs+import X.Y.D as Z+OUTPUT+tests/wildcards-x-y-d.hs:1:1-17: Warning: Avoid restricted alias+Found:+ import X.Y.D as Z+Perhaps:+ import X.Y.D as D+Note: may break the code++1 hint++----+RUN tests/wildcards-e.hs --hint=data/wildcards.yaml+FILE tests/wildcards-e.hs+module E where import E+OUTPUT+No hints++----+RUN tests/wildcards-xe.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xe.hs+module XE where import E+OUTPUT+tests/wildcards-xe.hs:1:17-24: Warning: Avoid restricted module+Found:+ import E+Note: may break the code++1 hint++----+RUN tests/wildcards-x-e.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-e.hs+module X.E where import E+OUTPUT+tests/wildcards-x-e.hs:1:18-25: Warning: Avoid restricted module+Found:+ import E+Note: may break the code++1 hint++----+RUN tests/wildcards-x-y-e.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-e.hs+module X.Y.E where import E+OUTPUT+tests/wildcards-x-y-e.hs:1:20-27: Warning: Avoid restricted module+Found:+ import E+Note: may break the code++1 hint++----+RUN tests/wildcards-f.hs --hint=data/wildcards.yaml+FILE tests/wildcards-f.hs+module F where import F+OUTPUT+No hints++----+RUN tests/wildcards-xf.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xf.hs+module XF where import F+OUTPUT+No hints++----+RUN tests/wildcards-x-f.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-f.hs+module X.F where import F+OUTPUT+tests/wildcards-x-f.hs:1:18-25: Warning: Avoid restricted module+Found:+ import F+Note: may break the code++1 hint++----+RUN tests/wildcards-x-y-f.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-f.hs+module X.Y.F where import F+OUTPUT+tests/wildcards-x-y-f.hs:1:20-27: Warning: Avoid restricted module+Found:+ import F+Note: may break the code++1 hint++----+RUN tests/wildcards-g.hs --hint=data/wildcards.yaml+FILE tests/wildcards-g.hs+module G where import G+OUTPUT+No hints++----+RUN tests/wildcards-xg.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xg.hs+module XG where import G+OUTPUT+tests/wildcards-xg.hs:1:17-24: Warning: Avoid restricted module+Found:+ import G+Note: may break the code++1 hint++----+RUN tests/wildcards-x-g.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-g.hs+module X.G where import G+OUTPUT+No hints++----+RUN tests/wildcards-x-y-g.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-g.hs+module X.Y.G where import G+OUTPUT+No hints++----+RUN tests/wildcards-h.hs --hint=data/wildcards.yaml+FILE tests/wildcards-h.hs+module H where import H+OUTPUT+No hints++----+RUN tests/wildcards-xh.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xh.hs+module XH where import H+OUTPUT+No hints++----+RUN tests/wildcards-x-h.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-h.hs+module X.H where import H+OUTPUT+No hints++----+RUN tests/wildcards-x-y-h.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-h.hs+module X.Y.H where import H+OUTPUT+No hints++----+RUN tests/wildcards-u.hs --hint=data/wildcards.yaml+FILE tests/wildcards-u.hs+module U where import U+OUTPUT+No hints++----+RUN tests/wildcards-module-xu.hs --hint=data/wildcards.yaml+FILE tests/wildcards-module-xu.hs+module XU where import U+OUTPUT+No hints++----+RUN tests/wildcards-module-x-u.hs --hint=data/wildcards.yaml+FILE tests/wildcards-module-x-u.hs+module X.U where import U+OUTPUT+No hints++----+RUN tests/wildcards-module-x-y-u.hs --hint=data/wildcards.yaml+FILE tests/wildcards-module-x-y-u.hs+module X.Y.U where import U+OUTPUT+No hints++----+RUN tests/wildcards-import-xu.hs --hint=data/wildcards.yaml+FILE tests/wildcards-import-xu.hs+module U where import XU+OUTPUT+No hints++----+RUN tests/wildcards-import-x-u.hs --hint=data/wildcards.yaml+FILE tests/wildcards-import-x-u.hs+module U where import X.U+OUTPUT+No hints++----+RUN tests/wildcards-import-x-y-u.hs --hint=data/wildcards.yaml+FILE tests/wildcards-import-x-y-u.hs+module U where import X.Y.U+OUTPUT+No hints++----+RUN tests/wildcards-module-w.hs --hint=data/wildcards.yaml+FILE tests/wildcards-module-w.hs+module W where import U+OUTPUT+tests/wildcards-module-w.hs:1:16-23: Warning: Avoid restricted module+Found:+ import U+Note: may break the code++1 hint++----+RUN tests/wildcard-i.hs --hint=data/wildcards.yaml+FILE tests/wildcard-i.hs+module I where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-xi.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xi.hs+module XI where x = y (\ _ -> z)+OUTPUT+tests/wildcard-xi.hs:1:24-31: Suggestion: Use const+Found:+ \ _ -> z+Perhaps:+ const z++1 hint++----+RUN tests/wildcard-x-i.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-i.hs+module X.I where x = y (\ _ -> z)+OUTPUT+tests/wildcard-x-i.hs:1:25-32: Suggestion: Use const+Found:+ \ _ -> z+Perhaps:+ const z++1 hint++----+RUN tests/wildcard-x-y-i.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-i.hs+module X.Y.I where x = y (\ _ -> z)+OUTPUT+tests/wildcard-x-y-i.hs:1:27-34: Suggestion: Use const+Found:+ \ _ -> z+Perhaps:+ const z++1 hint++----+RUN tests/wildcard-j.hs --hint=data/wildcards.yaml+FILE tests/wildcard-j.hs+module J where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-xj.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xj.hs+module XJ where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-x-j.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-j.hs+module X.J where x = y (\ _ -> z)+OUTPUT+tests/wildcard-x-j.hs:1:25-32: Suggestion: Use const+Found:+ \ _ -> z+Perhaps:+ const z++1 hint++----+RUN tests/wildcard-x-y-j.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-j.hs+module X.Y.J where x = y (\ _ -> z)+OUTPUT+tests/wildcard-x-y-j.hs:1:27-34: Suggestion: Use const+Found:+ \ _ -> z+Perhaps:+ const z++1 hint++----+RUN tests/wildcard-k.hs --hint=data/wildcards.yaml+FILE tests/wildcard-k.hs+module K where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-xk.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xk.hs+module XK where x = y (\ _ -> z)+OUTPUT+tests/wildcard-xk.hs:1:24-31: Suggestion: Use const+Found:+ \ _ -> z+Perhaps:+ const z++1 hint++----+RUN tests/wildcard-x-k.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-k.hs+module X.K where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-x-y-k.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-k.hs+module X.Y.K where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-l.hs --hint=data/wildcards.yaml+FILE tests/wildcard-l.hs+module L where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-xl.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xl.hs+module XL where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-x-l.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-l.hs+module X.L where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-x-y-l.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-l.hs+module X.Y.L where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-m.hs --hint=data/wildcards.yaml+FILE tests/wildcard-m.hs+{-# LANGUAGE CPP #-} module M where+OUTPUT+No hints++----+RUN tests/wildcard-xm.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xm.hs+{-# LANGUAGE CPP #-} module XM where+OUTPUT+tests/wildcard-xm.hs:1:1-20: Warning: Avoid restricted extensions+Found:+ {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-x-m.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-m.hs+{-# LANGUAGE CPP #-} module X.M where+OUTPUT+tests/wildcard-x-m.hs:1:1-20: Warning: Avoid restricted extensions+Found:+ {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-x-y-m.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-m.hs+{-# LANGUAGE CPP #-} module X.Y.M where+OUTPUT+tests/wildcard-x-y-m.hs:1:1-20: Warning: Avoid restricted extensions+Found:+ {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-n.hs --hint=data/wildcards.yaml+FILE tests/wildcard-n.hs+{-# LANGUAGE CPP #-} module N where+OUTPUT+No hints++----+RUN tests/wildcard-xn.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xn.hs+{-# LANGUAGE CPP #-} module XN where+OUTPUT+No hints++----+RUN tests/wildcard-x-n.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-n.hs+{-# LANGUAGE CPP #-} module X.N where+OUTPUT+tests/wildcard-x-n.hs:1:1-20: Warning: Avoid restricted extensions+Found:+ {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-x-y-n.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-n.hs+{-# LANGUAGE CPP #-} module X.Y.N where+OUTPUT+tests/wildcard-x-y-n.hs:1:1-20: Warning: Avoid restricted extensions+Found:+ {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-o.hs --hint=data/wildcards.yaml+FILE tests/wildcard-o.hs+{-# LANGUAGE CPP #-} module O where+OUTPUT+No hints++----+RUN tests/wildcard-xo.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xo.hs+{-# LANGUAGE CPP #-} module XO where+OUTPUT+tests/wildcard-xo.hs:1:1-20: Warning: Avoid restricted extensions+Found:+ {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-x-o.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-o.hs+{-# LANGUAGE CPP #-} module X.O where+OUTPUT+No hints++----+RUN tests/wildcard-x-y-o.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-o.hs+{-# LANGUAGE CPP #-} module X.Y.O where+OUTPUT+No hints++----+RUN tests/wildcard-p.hs --hint=data/wildcards.yaml+FILE tests/wildcard-p.hs+{-# LANGUAGE CPP #-} module P where+OUTPUT+No hints++----+RUN tests/wildcard-xp.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xp.hs+{-# LANGUAGE CPP #-} module XP where+OUTPUT+No hints++----+RUN tests/wildcard-x-p.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-p.hs+{-# LANGUAGE CPP #-} module X.P where+OUTPUT+No hints++----+RUN tests/wildcard-x-y-p.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-p.hs+{-# LANGUAGE CPP #-} module X.Y.P where+OUTPUT+No hints++----+RUN tests/wildcard-q.hs --hint=data/wildcards.yaml+FILE tests/wildcard-q.hs+module Q where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-xq.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xq.hs+module XQ where x = read ""+OUTPUT+tests/wildcard-xq.hs:1:21-24: Warning: Avoid restricted function+Found:+ read+Note: may break the code++1 hint++----+RUN tests/wildcard-x-q.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-q.hs+module X.Q where x = read ""+OUTPUT+tests/wildcard-x-q.hs:1:22-25: Warning: Avoid restricted function+Found:+ read+Note: may break the code++1 hint++----+RUN tests/wildcard-x-y-q.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-q.hs+module X.Y.Q where x = read ""+OUTPUT+tests/wildcard-x-y-q.hs:1:24-27: Warning: Avoid restricted function+Found:+ read+Note: may break the code++1 hint++----+RUN tests/wildcard-r.hs --hint=data/wildcards.yaml+FILE tests/wildcard-r.hs+module R where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-xr.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xr.hs+module XR where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-x-r.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-r.hs+module X.R where x = read ""+OUTPUT+tests/wildcard-x-r.hs:1:22-25: Warning: Avoid restricted function+Found:+ read+Note: may break the code++1 hint++----+RUN tests/wildcard-x-y-r.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-r.hs+module X.Y.R where x = read ""+OUTPUT+tests/wildcard-x-y-r.hs:1:24-27: Warning: Avoid restricted function+Found:+ read+Note: may break the code++1 hint++----+RUN tests/wildcard-s.hs --hint=data/wildcards.yaml+FILE tests/wildcard-s.hs+module S where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-xs.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xs.hs+module XS where x = read ""+OUTPUT+tests/wildcard-xs.hs:1:21-24: Warning: Avoid restricted function+Found:+ read+Note: may break the code++1 hint++----+RUN tests/wildcard-x-s.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-s.hs+module X.S where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-x-y-s.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-s.hs+module X.Y.S where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-t.hs --hint=data/wildcards.yaml+FILE tests/wildcard-t.hs+module T where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-xt.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xt.hs+module XT where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-x-t.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-t.hs+module X.T where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-x-y-t.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-t.hs+module X.Y.T where x = read ""+OUTPUT+No hints