hlint 3.5 → 3.10
raw patch · 69 files changed
Files
- .hlint.yaml +3/−1
- CHANGES.txt +49/−0
- LICENSE +1/−1
- README.md +4/−3
- data/default.yaml +3/−0
- data/do-block.yaml +2/−0
- data/hlint.yaml +332/−53
- data/import_style.yaml +2/−0
- hlint.cabal +11/−9
- src/Apply.hs +7/−5
- src/CC.hs +5/−4
- src/CmdLine.hs +30/−18
- src/Config/Compute.hs +7/−8
- src/Config/Haskell.hs +5/−4
- src/Config/Type.hs +2/−1
- src/Config/Yaml.hs +11/−9
- src/Extension.hs +3/−2
- src/Fixity.hs +4/−6
- src/GHC/All.hs +39/−13
- src/GHC/Util.hs +1/−1
- src/GHC/Util/ApiAnnotation.hs +22/−12
- src/GHC/Util/Brackets.hs +13/−9
- src/GHC/Util/DynFlags.hs +1/−1
- src/GHC/Util/FreeVars.hs +38/−29
- src/GHC/Util/HsExpr.hs +25/−26
- src/GHC/Util/Scope.hs +11/−11
- src/GHC/Util/SrcLoc.hs +6/−5
- src/GHC/Util/Unify.hs +39/−32
- src/GHC/Util/View.hs +4/−4
- src/HLint.hs +20/−4
- src/Hint/All.hs +3/−1
- src/Hint/Bracket.hs +44/−15
- src/Hint/Comment.hs +3/−2
- src/Hint/Duplicate.hs +4/−4
- src/Hint/Export.hs +3/−4
- src/Hint/Extensions.hs +51/−21
- src/Hint/Fixities.hs +0/−1
- src/Hint/Import.hs +9/−9
- src/Hint/Lambda.hs +23/−23
- src/Hint/List.hs +32/−26
- src/Hint/ListRec.hs +11/−11
- src/Hint/Match.hs +11/−11
- src/Hint/Monad.hs +29/−29
- src/Hint/Naming.hs +16/−11
- src/Hint/Negation.hs +62/−0
- src/Hint/NewType.hs +26/−19
- src/Hint/NumLiteral.hs +22/−9
- src/Hint/Pattern.hs +25/−20
- src/Hint/Pragma.hs +10/−5
- src/Hint/Restrict.hs +49/−30
- src/Hint/Smell.hs +6/−5
- src/Hint/Unsafe.hs +9/−6
- src/Idea.hs +3/−2
- src/Language/Haskell/HLint.hs +6/−5
- src/Refact.hs +8/−6
- src/Report.hs +3/−2
- src/SARIF.hs +178/−0
- src/Summary.hs +5/−3
- src/Test/Annotations.hs +3/−2
- src/Test/InputOutput.hs +5/−1
- src/Timing.hs +2/−1
- tests/cpp.test +39/−2
- tests/do-block.test +17/−0
- tests/flag-ignore-suggestions.test +38/−0
- tests/import_style.test +61/−0
- tests/lhs.test +1/−1
- tests/parse-error.test +3/−3
- tests/sarif.test +38/−0
- tests/serialise.test +0/−1
.hlint.yaml view
@@ -16,6 +16,7 @@ - extensions: - default: false+ - name: [ImportQualifiedPost] - name: [DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving, NoMonomorphismRestriction, OverloadedStrings] - name: [MultiWayIf, PatternGuards, RecordWildCards, ViewPatterns, PatternSynonyms, TupleSections, LambdaCase] - name: [Rank2Types, ScopedTypeVariables]@@ -26,6 +27,7 @@ - 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@@ -70,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,54 @@ 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
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2006-2022.+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: @@ -57,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. @@ -98,6 +98,7 @@ * [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 @@ -446,7 +447,7 @@ - modules: - {name: [Data.Map, Data.Map.*], as: Map} - {name: Test.Hspec, within: **.*Spec }- - {name: '**', importStyle: post}+ - {name: '**', qualifiedStyle: post} ``` ## Hacking HLint
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/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@@ -112,13 +116,11 @@ - 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}@@ -144,14 +146,18 @@ - 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}@@ -159,7 +165,7 @@ - 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}@@ -173,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}@@ -206,7 +214,10 @@ - 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}@@ -230,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}@@ -254,9 +269,9 @@ - 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}+ - 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}+ - 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}@@ -278,17 +293,27 @@ - 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/fmap}+ - 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 @@ -342,8 +367,8 @@ - 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 $}@@ -361,6 +386,7 @@ - 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 @@ -449,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}@@ -464,6 +494,12 @@ - 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 @@ -471,8 +507,14 @@ - hint: {lhs: return x <*> y, rhs: x <$> y} - warn: {lhs: x <* pure y, rhs: x} - warn: {lhs: x <* return y, rhs: x}- - warn: {lhs: pure x *> y, rhs: "y"}- - warn: {lhs: return x *> y, rhs: "y"}+ - 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 @@ -507,23 +549,29 @@ - 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} - 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: (>=>)}@@ -542,17 +590,23 @@ - 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: pure x *> m, rhs: m}- - warn: {lhs: return x *> m, rhs: m}- - warn: {lhs: pure x >> m, rhs: m}- - warn: {lhs: return x >> m, rhs: m}+ - 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 @@ -562,6 +616,7 @@ # 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}@@ -587,7 +642,7 @@ - warn: {lhs: flip traverse_, rhs: for_} - warn: {lhs: flip for_, rhs: traverse_} - warn: {lhs: foldr (*>) (pure ()), rhs: sequenceA_}- - warn: {lhs: foldr (*>) (return ()), rhs: sequenceA_}+ - warn: {lhs: foldr (*>) (return ()), rhs: sequence_} - warn: {lhs: foldr (<|>) empty, rhs: asum} - warn: {lhs: liftA2 (flip ($)), rhs: (<**>)} - warn: {lhs: liftA2 f (pure x), rhs: fmap (f x)}@@ -625,6 +680,7 @@ - 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 @@ -632,19 +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}@@ -654,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}@@ -664,23 +725,30 @@ - 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, 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 fmap}+ - 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 fmap}+ - 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}@@ -695,6 +763,7 @@ - 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 @@ -702,10 +771,20 @@ - 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}@@ -746,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 @@ -790,23 +869,88 @@ # FOLDABLE - - warn: {lhs: case m of Nothing -> pure (); Just x -> f x, rhs: Data.Foldable.forM_ m f}+ - 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.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.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}@@ -825,6 +969,14 @@ - 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}@@ -855,6 +1007,8 @@ - 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}@@ -886,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}@@ -906,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}@@ -943,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@@ -1041,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"}@@ -1095,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"}@@ -1110,15 +1370,29 @@ - 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:@@ -1169,6 +1443,7 @@ - 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@@ -1267,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@@ -1420,7 +1697,9 @@ # 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
@@ -4,3 +4,5 @@ - {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}
hlint.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.18 build-type: Simple name: hlint-version: 3.5+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-2022+copyright: Neil Mitchell 2006-2025 synopsis: Source code suggestions description: HLint gives suggestions on how to improve your source code.@@ -36,7 +36,7 @@ extra-doc-files: README.md CHANGES.txt-tested-with: GHC==9.2, GHC==9.0+tested-with: GHC==9.12, GHC==9.10, GHC==9.8 source-repository head type: git@@ -72,7 +72,7 @@ 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,@@ -81,16 +81,16 @@ deriving-aeson >= 0.2, filepattern >= 0.1.1 - if !flag(ghc-lib) && impl(ghc >= 9.4.1) && impl(ghc < 9.5.0)+ if !flag(ghc-lib) && impl(ghc >= 9.12.1) && impl(ghc < 9.13.0) build-depends:- ghc == 9.4.*,+ ghc == 9.12.*, ghc-boot-th, ghc-boot else build-depends:- ghc-lib-parser == 9.4.*+ ghc-lib-parser == 9.12.* build-depends:- ghc-lib-parser-ex >= 9.4.0.0 && < 9.4.1+ ghc-lib-parser-ex >= 9.12.0.0 && < 9.13.0 if flag(gpl) build-depends: hscolour >= 1.21@@ -124,6 +124,7 @@ Timing CC EmbedData+ SARIF Summary Config.Compute Config.Haskell@@ -158,6 +159,7 @@ Hint.Match Hint.Monad Hint.Naming+ Hint.Negation Hint.NewType Hint.Pattern Hint.Pragma@@ -170,7 +172,7 @@ Test.Annotations Test.InputOutput Test.Util- ghc-options: -Wunused-binds -Wunused-imports -Worphans+ 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 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 (comments (hsmodAnn (unLoc . ghcModule $ m)))+ exts = Set.fromList $ concatMap snd $ languagePragmas $ pragmas (comments (hsmodAnn (hsmodExt . unLoc . ghcModule $ m))) keep (RequiresExtension x) = not $ x `Set.member` exts keep _ = True
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@@ -84,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) @@ -96,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@@ -117,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@@ -144,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"@@ -158,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"@@ -167,7 +173,7 @@ ,cmdRefactorOptions = nam_ "refactor-options" &= typ "OPTIONS" &= help "Options to pass to the `refactor` executable" ,cmdWithRefactor = nam_ "with-refactor" &= help "Give the path to refactor" ,cmdIgnoreGlob = nam_ "ignore-glob" &= help "Ignore paths matching glob pattern (e.g. foo/bar/*.hs)"- ,cmdGenerateMdSummary = nam_ "generate-summary" &= opt "hints.md" &= help "Generate a summary of available hints, in Mardown format"+ ,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"@@ -177,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-2022")+ &= 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?@@ -219,19 +225,22 @@ {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))] } -- | 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@@ -270,7 +279,8 @@ 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@@ -317,7 +327,9 @@ langs, exts :: [String] (langs, exts) = partition (isJust . flip lookup ls) args- ls = [ (show x, x) | x <- [Haskell98, Haskell2010 , GHC2021] ]++ 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)
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@@ -46,24 +45,24 @@ 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=(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 EpAnnNotUsed x $ nlHsPar $ noLocA $ HsApp EpAnnNotUsed y $ noLocA $ mkVar "_hlint"+ HsApp noExtField x $ nlHsPar $ noLocA $ HsApp noExtField y $ noLocA $ mkVar "_hlint" findExp name vs bod = [SettingMatchExp $ HintRule Warning defaultHintName []@@ -74,7 +73,7 @@ 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 EpAnnNotUsed x $ nlHsPar y+ f (OpApp _ x dol y) | isDol dol = HsApp noExtField x $ nlHsPar y f x = x
src/Config/Haskell.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE PatternGuards, ViewPatterns, TupleSections #-} module Config.Haskell( readPragma,@@ -23,7 +24,7 @@ import GHC.Data.FastString import GHC.Parser.Annotation import GHC.Utils.Outputable-import qualified GHC.Data.Strict+import GHC.Data.Strict qualified import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader@@ -31,7 +32,7 @@ -- | 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@@ -44,7 +45,7 @@ Nothing -> errorOn expr "bad classify pragma" Just severity -> Just $ Classify severity (trimStart b) "" name where (a,b) = break isSpace $ trimStart $ drop 6 s- f (L _ (HsPar _ _ x _)) = f x+ f (L _ (HsPar _ x)) = f x f (L _ (ExprWithTySig _ x _)) = f x f _ = Nothing @@ -84,6 +85,6 @@ errorOnComment :: LEpaComment -> String -> b errorOnComment c@(L s _) msg = exitMessageImpure $ let isMultiline = isCommentMultiline c in- showSrcSpan (RealSrcSpan (anchor s) GHC.Data.Strict.Nothing) +++ 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,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DataKinds #-}@@ -18,7 +19,7 @@ import Prelude -import qualified GHC.Hs+import GHC.Hs qualified import Fixity import GHC.Util import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
src/Config/Yaml.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings, ViewPatterns, RecordWildCards, GeneralizedNewtypeDeriving, TupleSections #-}@@ -28,13 +29,14 @@ import Config.Type 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@@ -67,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@@ -162,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]@@ -234,8 +236,8 @@ case parser defaultParseFlags{enabledExtensions=configExtensions, disabledExtensions=[]} x of POk _ x -> pure x PFailed ps ->- let errMsg = head . bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages ps)- msg = showSDoc baseDynFlags $ pprLocMsgEnvelope 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 ---------------------------------------------------------------------@@ -440,7 +442,7 @@ scope'= asScope' packageMap' (map (fmap unextendInstances) groupImports) asScope' :: Map.HashMap String [LocatedA (ImportDecl GhcPs)] -> [Either String (LocatedA (ImportDecl GhcPs))] -> Scope-asScope' packages xs = scopeCreate (HsModule EpAnnNotUsed NoLayoutInfo Nothing Nothing (concatMap f xs) [] Nothing Nothing)+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/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 ++
src/Fixity.hs view
@@ -12,9 +12,7 @@ import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader import GHC.Types.Fixity-import GHC.Types.SourceText import GHC.Parser.Annotation-import Language.Haskell.Syntax.Extension import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import Language.Haskell.GhclibParserEx.Fixity @@ -29,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@@ -37,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@@ -52,7 +50,7 @@ InfixN -> NotAssociative toFixitySig :: FixityInfo -> FixitySig GhcPs-toFixitySig (toFixity -> (name, x)) = FixitySig noExtField [noLocA $ 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,7 +6,7 @@ CppFlags(..), ParseFlags(..), defaultParseFlags, parseFlagsAddFixities, parseFlagsSetLanguage, ParseError(..), ModuleEx(..),- parseModuleEx, createModuleEx, createModuleExWithFixities, ghcComments, modComments,+ parseModuleEx, createModuleEx, createModuleExWithFixities, ghcComments, modComments, firstDeclComments, parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode, ) where @@ -14,6 +15,8 @@ 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@@ -22,7 +25,7 @@ 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@@ -37,6 +40,8 @@ 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.@@ -85,7 +90,7 @@ -- | Result of 'parseModuleEx', representing a parsed module. newtype ModuleEx = ModuleEx {- ghcModule :: Located HsModule+ ghcModule :: Located (HsModule GhcPs) } -- | Extract a complete list of all the comments in a module.@@ -94,8 +99,15 @@ -- | Extract just the list of a modules' leading comments (pragmas). modComments :: ModuleEx -> EpAnnComments-modComments = comments . hsmodAnn . unLoc . ghcModule+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@@ -117,12 +129,12 @@ 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 @@ -147,13 +159,23 @@ -- | 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 -> ModuleEx+createModuleEx :: Located (HsModule GhcPs) -> ModuleEx createModuleEx = createModuleExWithFixities (map toFixity defaultFixities) -createModuleExWithFixities :: [(String, Fixity)] -> Located HsModule -> ModuleEx+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@@ -170,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,12 +211,12 @@ POk s a -> do 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 fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags pure $ ModuleEx (applyFixities fixes a) PFailed s ->- ExceptT $ parseFailureErr dynFlags str file str $ bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages s)+ 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.@@ -199,9 +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- doc = pprLocMsgEnvelope 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,8 +1,15 @@+{-# 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 @@ -16,7 +23,7 @@ import Control.Applicative import Data.List.Extra import Data.Maybe-import qualified Data.Set as Set+import Data.Set qualified as Set trimCommentStart :: String -> String trimCommentStart s@@ -38,12 +45,16 @@ comment_ (L _ (EpaComment (EpaDocOptions s) _)) = s comment_ (L _ (EpaComment (EpaLineComment s) _)) = s comment_ (L _ (EpaComment (EpaBlockComment s) _)) = s-comment_ (L _ (EpaComment EpaEofComment _)) = "" -- | The comment string with delimiters removed. commentText :: LEpaComment -> String commentText = trimCommentDelims . comment_ +-- | Total replacement for the partial `GHC.Parser.Annotation.comments` field of+-- `EpAnn`+comments :: EpAnn ann -> EpAnnComments+comments EpAnn{ GHC.Parser.Annotation.comments = result } = result+ isCommentMultiline :: LEpaComment -> Bool isCommentMultiline (L _ (EpaComment (EpaBlockComment _) _)) = True isCommentMultiline _ = False@@ -64,8 +75,7 @@ -- All the extensions defined to be used. extensions :: EpAnnComments -> Set.Set Extension-extensions = Set.fromList . mapMaybe readExtension .- concatMap snd . languagePragmas . pragmas+extensions = Set.fromList . concatMap (mapMaybe readExtension . snd) . languagePragmas . pragmas -- Utility for a case insensitive prefix strip. stripPrefixCI :: String -> String -> Maybe String@@ -87,7 +97,7 @@ -- 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.+-- pragmas enumerated by the second element of the pair. languagePragmas :: [(LEpaComment, String)] -> [(LEpaComment, [String])] languagePragmas ps = [(c, exts) | (c, s) <- ps@@ -95,10 +105,10 @@ , let exts = map trim (splitOn "," rest)] -- Given a list of flags, make a GHC options pragma.-mkFlags :: Anchor -> [String] -> LEpaComment+mkFlags :: NoCommentsLocation -> [String] -> LEpaComment mkFlags anc flags =- L anc $ EpaComment (EpaBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")) (anchor anc)+ L anc $ EpaComment (EpaBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")) (epaLocationRealSrcSpan anc) -mkLanguagePragmas :: Anchor -> [String] -> LEpaComment+mkLanguagePragmas :: NoCommentsLocation -> [String] -> LEpaComment mkLanguagePragmas anc exts =- L anc $ EpaComment (EpaBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")) (anchor anc)+ L anc $ EpaComment (EpaBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")) (epaLocationRealSrcSpan anc)
src/GHC/Util/Brackets.hs view
@@ -26,9 +26,9 @@ -- result in a "naked" section. Consequently, given an expression, -- when stripping brackets (c.f. 'Hint.Brackets), don't remove the -- paren's surrounding a section - they are required.- remParen (L _ (HsPar _ _ (L _ SectionL{}) _)) = Nothing- remParen (L _ (HsPar _ _ (L _ SectionR{}) _)) = Nothing- remParen (L _ (HsPar _ _ x _)) = Just x+ remParen (L _ (HsPar _ (L _ SectionL{}))) = Nothing+ remParen (L _ (HsPar _ (L _ SectionR{}))) = Nothing+ remParen (L _ (HsPar _ x)) = Just x remParen _ = Nothing addParen = nlHsPar@@ -36,8 +36,8 @@ isAtom (L _ x) = case x of HsVar{} -> True HsUnboundVar{} -> True- -- Technically atomic, but lots of people think it shouldn't be- HsRecSel{} -> False+ -- Only relevant for OverloadedRecordDot extension+ HsGetField{} -> True HsOverLabel{} -> True HsIPVar{} -> True -- Note that sections aren't atoms (but parenthesized sections are).@@ -52,7 +52,8 @@ 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@@ -105,8 +106,9 @@ isAtomOrApp _ = False instance Brackets (LocatedA (Pat GhcPs)) where- remParen (L _ (ParPat _ _ x _)) = Just x+ remParen (L _ (ParPat _ x)) = Just x remParen _ = Nothing+ addParen = nlParPat isAtom (L _ x) = case x of@@ -115,7 +117,9 @@ ListPat{} -> True -- This is technically atomic, but lots of people think it shouldn't be ConPat _ _ RecCon{} -> False- ConPat _ _ (PrefixCon _ []) -> True+ -- 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@@ -145,7 +149,7 @@ instance Brackets (LocatedA (HsType GhcPs)) where remParen (L _ (HsParTy _ x)) = Just x remParen _ = Nothing- addParen e = noLocA $ HsParTy EpAnnNotUsed e+ addParen e = noLocA $ HsParTy noAnn e isAtom (L _ x) = case x of HsParTy{} -> True
src/GHC/Util/DynFlags.hs view
@@ -8,7 +8,7 @@ -- 'parsePragmasIntoDynFlags' based solely on the parse flags -- (and source level annotations). baseDynFlags :: DynFlags-baseDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig+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@@ -97,23 +97,37 @@ 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 _ (HsLet _ binds e)) = inFree binds e -- Let (rec).+ 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- Left fs -> Set.unions $ freeVars e : map freeVars fs- Right ps -> Set.unions $ freeVars e : map freeVars ps+ 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 _ (HsTypedBracket _ e)) = freeVars e freeVars (L _ (HsUntypedBracket _ (ExpBr _ e))) = freeVars e freeVars (L _ (HsUntypedBracket _ (VarBr _ _ v))) = Set.fromList [occName (unLoc v)] - freeVars (L _ HsRecSel{}) = 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.@@ -153,26 +167,23 @@ freeVars (Present _ args) = freeVars args freeVars _ = mempty -instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where+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 (LocatedA (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where- freeVars (L _ (HsFieldBind _ _ x _)) = freeVars x- instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) (LocatedA (HsExpr GhcPs)))) where freeVars (L _ (HsFieldBind _ _ x _)) = freeVars x 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 (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) <> allVars x -- As pattern.- allVars (L _ (ConPat _ _ (RecCon (HsRecFields flds _)))) = allVars flds+ 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.@@ -186,7 +197,7 @@ allVars p = allVars $ children p -instance AllVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) (LocatedA (Pat GhcPs)))) where+instance AllVars (LocatedA (HsFieldBind (LocatedA (FieldOcc GhcPs)) (LocatedA (Pat GhcPs)))) where allVars (L _ (HsFieldBind _ _ x _)) = allVars x instance AllVars (LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))) where@@ -196,12 +207,10 @@ 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_ (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 _ ApplicativeStmt{}) = mempty -- Generated by the renamer. allVars (L _ ParStmt{}) = mempty -- Parallel list thing. Come back to it. instance AllVars (HsLocalBinds GhcPs) where- allVars (HsValBinds _ (ValBinds _ binds _)) = allVars (bagToList binds) -- Value bindings.+ 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@@ -216,15 +225,15 @@ allVars (L _ (PatSynBind _ PSB{})) = mempty -- Come back to it. instance AllVars (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where- allVars (MG _ _alts@(L _ alts) _) = inVars (foldMap (allVars . m_pats) ms) (allVars (map m_grhss ms))+ 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 (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 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.+ 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+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.
src/GHC/Util/HsExpr.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}@@ -20,13 +21,11 @@ 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@@ -39,7 +38,7 @@ 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@@ -49,7 +48,7 @@ -- | 'dotApp a b' makes 'a . b'. dotApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs-dotApp x y = noLocA $ OpApp EpAnnNotUsed x (noLocA $ HsVar noExtField (noLocA $ 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"@@ -58,7 +57,7 @@ -- | @lambda [p0, p1..pn] body@ makes @\p1 p1 .. pn -> body@ lambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs-lambda vs body = noLocA $ HsLam noExtField (MG noExtField (noLocA [noLocA $ Match EpAnnNotUsed LambdaExpr vs (GRHSs emptyComments [noLocA $ GRHS EpAnnNotUsed [] body] (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@@ -72,7 +71,7 @@ apps :: [LHsExpr GhcPs] -> LHsExpr GhcPs-apps = foldl1' mkApp where mkApp x y = noLocA (HsApp EpAnnNotUsed 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]@@ -86,7 +85,7 @@ 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 EpAnnNotUsed 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)@@ -117,15 +116,15 @@ -- A list of application, with any necessary brackets. appsBracket :: [LHsExpr GhcPs] -> LHsExpr GhcPs appsBracket = foldl1 mkApp- where mkApp x y = rebracket1 (noLocA $ HsApp EpAnnNotUsed 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 EpAnnNotUsed x (nlHsPar y))-simplifyExp e@(L _ (HsLet _ _ ((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)] ((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 ->@@ -159,7 +158,7 @@ niceLambdaR xs (SimpleLambda [] x) = niceLambdaR xs x -- Rewrite @\xs -> (e)@ as @\xs -> e@.-niceLambdaR xs (L _ (HsPar _ _ x _)) = niceLambdaR xs x+niceLambdaR xs (L _ (HsPar _ x)) = niceLambdaR xs x -- @\vs v -> ($) e v@ ==> @\vs -> e@ -- @\vs v -> e $ v@ ==> @\vs -> e@@@ -177,7 +176,7 @@ , vars e `disjoint` [v] , L _ (HsVar _ (L _ fname)) <- f , isSymOcc $ rdrNameOcc fname- = let res = nlHsPar $ noLocA $ SectionL EpAnnNotUsed 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@@@ -198,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 (noLocA $ SectionR EpAnnNotUsed 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@@ -213,7 +212,7 @@ factor (L _ (OpApp _ y op (factor -> Just (z, ss))))| isDol op = let r = niceDotApp y z in if astEq r z then Just (r, ss) else Just (r, y : ss)- factor (L _ (HsPar _ _ y@(L _ HsApp{}) _)) = factor y+ factor (L _ (HsPar _ y@(L _ HsApp{}))) = factor y factor _ = Nothing mkRefact :: [LHsExpr GhcPs] -> R.SrcSpan -> Refactoring R.SrcSpan mkRefact subts s =@@ -231,7 +230,7 @@ ) where gen :: LHsExpr GhcPs -> LHsExpr GhcPs- gen = noLocA . HsApp EpAnnNotUsed (strToVar "flip")+ 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.@@ -239,20 +238,20 @@ niceLambdaR [] e = (e, \s -> [Replace Expr s [("a", toSSA e)] "a"]) -- Base case. Just a good old fashioned lambda. niceLambdaR ss e =- let grhs = noLocA $ GRHS EpAnnNotUsed [] e :: LGRHS GhcPs (LHsExpr GhcPs)+ let grhs = noLocA $ GRHS noAnn [] e :: LGRHS GhcPs (LHsExpr GhcPs) grhss = GRHSs {grhssExt = emptyComments, grhssGRHSs=[grhs], grhssLocalBinds=EmptyLocalBinds noExtField}- match = noLocA $ Match {m_ext=EpAnnNotUsed, 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=noLocA [match]}- in (noLocA $ HsLam noExtField matchGroup, const [])+ 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 EpAnnNotUsed 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 EpAnnNotUsed 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]@@ -260,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 EpAnnNotUsed CaseAlt a (GRHSs emptyComments [L a (GRHS EpAnnNotUsed 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"@@ -298,7 +297,7 @@ g1 a b = fst (g a b) g2 a b = writer $ snd (g a b) - f i (L _ (HsPar _ _ y _)) z w+ 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
src/GHC/Util/Scope.hs view
@@ -10,7 +10,6 @@ import GHC.Hs import GHC.Types.SrcLoc import GHC.Types.SourceText-import GHC.Unit.Module import GHC.Data.FastString import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence@@ -21,6 +20,7 @@ import Data.List.Extra import Data.Maybe+import Data.Bifunctor -- A scope is a list of import declarations. newtype Scope = Scope [LImportDecl GhcPs]@@ -30,7 +30,7 @@ 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.@@ -40,13 +40,13 @@ 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") Nothing) ] - -- Mock up an import declaraion corresponding to 'import Prelude'.+ -- Mock up an import declaration corresponding to 'import Prelude'. prelude :: LImportDecl GhcPs prelude = noLocA $ simpleImportDecl (mkModuleName "Prelude") @@ -116,10 +116,10 @@ where ms = map unLoc $ ideclName i : maybeToList (ideclAs i) possImport (L _ i) (L _ (Unqual x)) = if ideclQualified i == NotQualified- then maybe PossiblyImported f (ideclHiding i)+ then maybe PossiblyImported (f . first (== EverythingBut)) (ideclImportList i) else NotImported where- f :: (Bool, LocatedL [LIE GhcPs]) -> IsImported+ 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@@ -131,12 +131,12 @@ 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)) = 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 _ _ = NotImported
src/GHC/Util/SrcLoc.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Util.SrcLoc (@@ -10,16 +11,16 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Data.FastString-import qualified GHC.Data.Strict+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 'Anchor' (e.g.--- comments).-getAncLoc :: GenLocated Anchor a -> SrcSpan-getAncLoc o = RealSrcSpan (anchor (getLoc o)) GHC.Data.Strict.Nothing+-- 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'.
src/GHC/Util/Unify.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables, TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}+{-# LANGUAGE DataKinds #-} module GHC.Util.Unify( Subst(..), fromSubst,@@ -61,10 +62,10 @@ removeParens noParens (Subst xs) = Subst $ map (\(x, y) -> if x `elem` noParens then (x, fromParen y) else (x, y)) xs --- Peform a substition.+-- 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 substituation variables which, when expanded, should have the brackets stripped.+-- is a list of substitution variables which, when expanded, should have the brackets stripped. -- -- Examples: -- (traverse foo (bar baz), (traverse f (x), []))@@ -77,13 +78,13 @@ exp (L _ (HsVar _ x)) = lookup (rdrNameStr x) bind -- Operator applications. exp (L loc (OpApp _ lhs (L _ (HsVar _ x)) rhs))- | Just y <- lookup (rdrNameStr x) bind = Just (L loc (OpApp EpAnnNotUsed lhs y rhs))+ | Just y <- lookup (rdrNameStr x) bind = Just (L loc (OpApp noExtField lhs y rhs)) -- Left sections. exp (L loc (SectionL _ exp (L _ (HsVar _ x))))- | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionL EpAnnNotUsed exp y))+ | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionL noExtField exp y)) -- Right sections. exp (L loc (SectionR _ (L _ (HsVar _ x)) exp))- | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionR EpAnnNotUsed y exp))+ | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionR noExtField y exp)) exp _ = Nothing pat :: LPat GhcPs -> LPat GhcPs@@ -114,30 +115,36 @@ | Just (x, y) <- cast (x, y) = if (x :: FastString) == y then Just mempty else Nothing -- We need some type magic to reduce this.- | Just (x :: EpAnn AnnsModule) <- cast x = Just mempty- | Just (x :: EpAnn NameAnn) <- cast x = Just mempty- | Just (x :: EpAnn AnnListItem) <- cast x = Just mempty- | Just (x :: EpAnn AnnList) <- cast x = Just mempty- | Just (x :: EpAnn AnnPragma) <- cast x = Just mempty+ | Just (x :: EpAnn EpaLocation) <- cast x = Just mempty | Just (x :: EpAnn AnnContext) <- cast x = Just mempty- | Just (x :: EpAnn AnnParen) <- cast x = Just mempty- | Just (x :: EpAnn Anchor) <- cast x = Just mempty- | Just (x :: EpAnn NoEpAnns) <- cast x = Just mempty- | Just (x :: EpAnn GrhsAnn) <- cast x = Just mempty- | Just (x :: EpAnn [AddEpAnn]) <- cast x = Just mempty- | Just (x :: EpAnn EpAnnHsCase) <- cast x = Just mempty- | Just (x :: EpAnn EpAnnUnboundVar) <- cast x = Just mempty | Just (x :: EpAnn AnnExplicitSum) <- cast x = Just mempty- | Just (x :: EpAnn AnnProjection) <- cast x = Just mempty- | Just (x :: EpAnn Anchor) <- cast x = Just mempty- | Just (x :: EpAnn EpaLocation) <- cast x = Just mempty | Just (x :: EpAnn AnnFieldLabel) <- cast x = Just mempty- | Just (x :: EpAnn EpAnnSumPat) <- 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 HsRuleAnn) <- 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 (AddEpAnn, AddEpAnn)) <- cast x = Just mempty- | Just (x :: EpAnn AnnsIf) <- 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 @@ -155,7 +162,7 @@ ((, Just y11) <$> unifyExp' nm False x1 y12) <|> case y12 of (L _ (OpApp _ y121 dot' y122)) | isDot dot' ->- unifyComposed' nm x1 (noLocA (OpApp EpAnnNotUsed 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,@@ -189,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 (noLocA (HsApp EpAnnNotUsed y11 (noLocA (HsApp EpAnnNotUsed 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',@@ -204,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 $ noLocA (HsApp EpAnnNotUsed lhs2 rhs2)- | isAmp op2 = unifyExp nm root x $ noLocA (HsApp EpAnnNotUsed rhs2 lhs2)- | otherwise = unifyExp nm root x $ noLocA (HsApp EpAnnNotUsed (noLocA (HsApp EpAnnNotUsed 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@@ -228,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@@ -288,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 noSrcSpan 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
@@ -18,7 +18,7 @@ fromParen x = maybe x fromParen $ remParen x fromPParen :: LocatedA (Pat GhcPs) -> LocatedA (Pat GhcPs)-fromPParen (L _ (ParPat _ _ x _ )) = fromPParen x+fromPParen (L _ (ParPat _ x)) = fromPParen x fromPParen x = x class View a b where@@ -32,8 +32,8 @@ data LamConst1 = NoLamConst1 | LamConst1 (LocatedA (HsExpr GhcPs)) instance View (LocatedA (HsExpr GhcPs)) LamConst1 where- view (fromParen -> (L _ (HsLam _ (MG _ (L _ [L _ (Match _ LambdaExpr [L _ WildPat {}]- (GRHSs _ [L _ (GRHS _ [] x)] ((EmptyLocalBinds _))))]) FromSource)))) = LamConst1 x+ view (fromParen -> (L _ (HsLam _ _ (MG FromSource (L _ [L _ (Match _ (LamAlt _) (L _ [L _ WildPat {}])+ (GRHSs _ [L _ (GRHS _ [] x)] ((EmptyLocalBinds _))))]))))) = LamConst1 x view _ = NoLamConst1 instance View (LocatedA (HsExpr GhcPs)) RdrName_ where@@ -62,4 +62,4 @@ -- A lambda with no guards and no where clauses pattern SimpleLambda :: [LocatedA (Pat GhcPs)] -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)-pattern SimpleLambda vs body <- L _ (HsLam _ (MG _ (L _ [L _ (Match _ _ vs (GRHSs _ [L _ (GRHS _ [] body)] ((EmptyLocalBinds _))))]) _))+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.@@ -167,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@@ -184,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@@ -219,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@@ -37,7 +38,7 @@ -- | 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 | HintNumLiteral@@ -63,6 +64,7 @@ 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
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@@ -104,6 +112,17 @@ -- 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> -} @@ -127,25 +146,32 @@ bracketHint :: DeclHint bracketHint _ _ x = concatMap (\x -> bracket prettyExpr isPartialAtom True x ++ dollar x) (childrenBi (descendBi splices $ descendBi annotations x) :: [LHsExpr GhcPs]) ++- concatMap (bracket unsafePrettyPrint (\_ _ -> False) False) (childrenBi x :: [LHsType 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+ 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+ 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@@ -162,12 +188,15 @@ 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 (LocatedA a)) => (LocatedA a -> String) -> (Maybe (LocatedA a) -> LocatedA a -> Bool) -> Bool -> LocatedA a -> [Idea]@@ -242,32 +271,32 @@ dollar = concatMap f . universe where 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 EpAnnNotUsed a b) :: LHsExpr GhcPs+ , 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 (toSSA x) [("a", toSSA a), ("b", toSSA b)] "a b"] ++ [ suggest "Move brackets to avoid $" (reLoc x) (reLoc (t y)) [r]- |(t, e@(L _ (HsPar _ _ (L _ (OpApp _ a1 op1 a2)) _))) <- splitInfix x+ |(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 = noLocA $ HsApp EpAnnNotUsed a1 (nlHsPar a2)+ , 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" (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 = noLocA (OpApp EpAnnNotUsed o1 o2 v3) :: LHsExpr GhcPs+ | L _ (OpApp _ (L locPar (HsPar _ o1@(L locNoPar (OpApp _ _ (isDot -> True) _)))) o2 v3) <- [x], varToStr o2 == "<$>"+ , 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" (reLoc x) (reLoc y) [r]- | L _ (HsApp _ (L _ (HsPar _ _ (L _ (SectionL _ a b)) _)) c) <- [x]+ | L _ (HsApp _ (L _ (HsPar _ (L _ (SectionL _ a b)))) c) <- [x] -- , error $ show (unsafePrettyPrint a, gshow b, unsafePrettyPrint c)- , let y = noLocA $ OpApp EpAnnNotUsed a b c :: LHsExpr GhcPs+ , 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)) =- [(L l . OpApp EpAnnNotUsed lhs op, rhs), (\lhs -> L l (OpApp EpAnnNotUsed lhs op rhs), lhs)]+ [(L l . OpApp noExtField lhs op, rhs), (\lhs -> L l (OpApp noExtField lhs op rhs), lhs)] splitInfix _ = []
src/Hint/Comment.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {- <TEST>@@ -21,7 +22,7 @@ import GHC.Types.SrcLoc import GHC.Parser.Annotation import GHC.Util-import qualified GHC.Data.Strict+import GHC.Data.Strict qualified directives :: [String] directives = words $@@ -45,7 +46,7 @@ grab :: String -> LEpaComment -> String -> Idea grab msg o@(L pos _) s2 = let s1 = commentText o- loc = RealSrcSpan (anchor pos) GHC.Data.Strict.Nothing+ 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
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,7 +53,7 @@ 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)
src/Hint/Export.hs view
@@ -16,7 +16,6 @@ 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@@ -24,7 +23,7 @@ exportHint :: ModuHint exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) ) | Nothing <- exports =- let r = o{ hsmodExports = Just (noLocA [noLocA (IEModuleContents EpAnnNotUsed 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 (noLocA (noLocA (IEVar noExtField (noLocA (IEName (noLocA 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,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase, NamedFieldPuns, ScopedTypeVariables #-} {-@@ -98,7 +99,7 @@ {-# 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)+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 #-} \@@ -248,13 +249,20 @@ 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(..),toSSAnc,ghcModule,modComments)+import Hint.Type(ModuHint,rawIdea,Severity(Warning),Note(..),toSSAnc,ghcModule,modComments,firstDeclComments) import Extension import Data.Generics.Uniplate.DataOnly@@ -263,16 +271,17 @@ 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.Types.Name.Reader import GHC.Types.ForeignCall-import qualified GHC.Data.Strict+import GHC.Data.Strict qualified import GHC.Types.PkgQual import GHC.Util@@ -292,14 +301,20 @@ extensionsHint _ x = [ rawIdea Hint.Type.Warning "Unused LANGUAGE pragma"- (RealSrcSpan (anchor sl) GHC.Data.Strict.Nothing)+ (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 (toSSAnc (mkLanguagePragmas sl exts)) newPragma]- | (L sl _, exts) <- languagePragmas $ pragmas (modComments x)+ | (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@@ -319,8 +334,16 @@ -- All the extensions defined to be used. extensions :: Set.Set Extension- extensions = Set.fromList $ mapMaybe readExtension $- concatMap snd $ languagePragmas (pragmas (modComments 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@@ -370,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.@@ -378,27 +401,34 @@ usedExt DeriveAnyClass = not . null . derivesAnyclass . derives usedExt x = used x -used :: Extension -> Located HsModule -> Bool+used :: Extension -> Located (HsModule GhcPs) -> Bool used RecursiveDo = hasS isMDo ||^ hasS isRecStmt used ParallelListComp = hasS isParComp used FunctionalDependencies = hasT (un :: FunDep GhcPs) used ImplicitParams = hasT (un :: HsIPName)+ 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 = hasS $ not . isQuasiQuoteSplice+used TemplateHaskell = hasS (not . isQuasiQuoteSplice) ||^ hasS isTypedSplice used TemplateHaskellQuotes = hasS f where f :: HsExpr GhcPs -> Bool@@ -463,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@@ -497,7 +527,7 @@ 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@@ -526,14 +556,14 @@ ,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 :: DataFamInstDecl GhcPs -> Derives- idecl (DataFamInstDecl FamEqn {feqn_rhs=HsDataDefn {dd_ND=dn, dd_derivs=ds}}) = g dn ds+ 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=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
src/Hint/Fixities.hs view
@@ -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.@@ -39,7 +40,7 @@ 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@@ -51,7 +52,6 @@ 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@@ -107,15 +107,15 @@ -- 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, noLocA (unLoc xs ++ unLoc ys))}+ , 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)+ | 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'.@@ -133,8 +133,8 @@ 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 _ i@ImportDecl {..})
src/Hint/Lambda.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase, PatternGuards, TupleSections, ViewPatterns #-} {-@@ -86,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)@@ -110,7 +112,7 @@ import Util import Data.List.Extra import Data.Set (Set)-import qualified Data.Set as Set+import Data.Set qualified as Set import Refact.Types hiding (Match) import Data.Generics.Uniplate.DataOnly (universe, universeBi, transformBi) @@ -121,6 +123,7 @@ import GHC.Types.Name.Reader import GHC.Types.SrcLoc 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)@@ -146,7 +149,7 @@ lambdaBind o@(L _ 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))]}}) rtype+ 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])@@ -169,7 +172,7 @@ where reform :: [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs) reform ps b = L (combineSrcSpans (locA loc1) (locA loc2)) $ ValD noExtField $- origBind {fun_matches = MG noExtField (noLocA [noLocA $ Match EpAnnNotUsed ctxt ps $ GRHSs emptyComments [noLocA $ GRHS EpAnnNotUsed [] b] $ EmptyLocalBinds noExtField]) Generated}+ 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@@ -185,11 +188,11 @@ , y `notElem` vars x , not $ any isQuasiQuoteExpr $ universe x = etaReduce ps x-etaReduce ps (L loc (OpApp _ x (isDol -> True) y)) = etaReduce ps (L loc (HsApp EpAnnNotUsed x y))+etaReduce ps (L loc (OpApp _ x (isDol -> True) y)) = etaReduce ps (L loc (HsApp noExtField x y)) etaReduce ps x = (ps, x) lambdaExp :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]-lambdaExp _ o@(L _ (HsPar _ _ (L _ (HsApp _ oper@(L _ (HsVar _ origf@(L _ (rdrNameOcc -> f)))) y)) _))+lambdaExp _ o@(L _ (HsPar _ (L _ (HsApp _ oper@(L _ (HsVar _ origf@(L _ (rdrNameOcc -> f)))) y)))) | isSymOcc f -- is this an operator? , isAtom y , allowLeftSection $ occNameString f@@ -197,22 +200,22 @@ = [suggest "Use section" (reLoc o) (reLoc to) [r]] where to :: LHsExpr GhcPs- to = nlHsPar $ noLocA $ SectionL EpAnnNotUsed y oper+ 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) _))+lambdaExp _ o@(L _ (HsPar _ (view -> App2 (view -> Var_ "flip") origf@(view -> RdrName_ f) y))) | allowRightSection (rdrNameStr f), not $ "(" `isPrefixOf` rdrNameStr f = [suggest "Use section" (reLoc o) (reLoc to) [r]] where to :: LHsExpr GhcPs- to = nlHsPar $ noLocA $ SectionR EpAnnNotUsed 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 (toSSA o) [(var, toSSA y)] ("(" ++ op ++ " " ++ var ++ ")") -lambdaExp p o@(L _ HsLam{})+lambdaExp p o@(L _ (HsLam _ LamSingle _)) | not $ any isOpApp p , (res, refact) <- niceLambdaR [] o , not $ isLambda res@@ -222,7 +225,7 @@ -- If the lambda's parent is an HsPar, and the result is also an HsPar, the span should include the parentheses. , let from = case p of -- Avoid creating redundant bracket.- Just p@(L _ (HsPar _ _ (L _ HsLam{}) _))+ Just p@(L _ (HsPar _ (L _ HsLam{}))) | L _ HsPar{} <- res -> p | L _ (HsVar _ (L _ name)) <- res, not (isSymbolRdrName name) -> p _ -> o@@ -251,7 +254,7 @@ | ([_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" (reLoc o) $ noLoc $ ExplicitTuple EpAnnNotUsed (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@@ -265,9 +268,9 @@ -- 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 (locA . getLoc) (m_pats oldmatch)+ 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 =@@ -277,13 +280,13 @@ ((if needParens then "\\(x)" else "\\x") ++ " -> y") ] | otherwise = []- needParens = any (patNeedsParens appPrec . unLoc) (m_pats oldmatch)+ needParens = any (patNeedsParens appPrec . unLoc) ((unLoc . m_pats) oldmatch) in [ suggest "Use lambda" (reLoc o)- ( noLoc $ HsLam noExtField oldMG+ ( noLoc $ HsLam noAnn LamSingle oldMG { mg_alts = noLocA [ noLocA oldmatch- { m_pats = map mkParPat $ m_pats oldmatch- , m_ctxt = LambdaExpr+ { m_pats = L noSpanAnchor (map mkParPat $ (unLoc . m_pats) oldmatch)+ , m_ctxt = LamAlt LamSingle } ] }@@ -293,8 +296,8 @@ ] -- otherwise we should use @LambdaCase@- MG _ (L _ _) _ ->- [(suggestN "Use lambda-case" (reLoc o) $ noLoc $ HsLamCase EpAnnNotUsed LamCase matchGroup)+ MG _ (L _ _) ->+ [(suggestN "Use lambda-case" (reLoc o) $ noLoc $ HsLam noAnn LamCase matchGroup) {ideaNote=[RequiresExtension "LambdaCase"]}] _ -> [] where@@ -302,7 +305,7 @@ -- to a missing argument, so that we get the proper section. removeX :: HsTupArg GhcPs -> HsTupArg GhcPs removeX (Present _ (view -> Var_ x'))- | x == x' = Missing EpAnnNotUsed+ | x == x' = Missing noAnn removeX y = y -- | Extract the name of an argument of a tuple if it's present and a variable. tupArgVar :: HsTupArg GhcPs -> Maybe String@@ -343,9 +346,6 @@ let used = Set.fromList [rdrNameStr name | (L _ (VarPat _ name)) <- universe p] 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
src/Hint/List.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-} {- Find and match:@@ -43,18 +44,18 @@ 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,toSSA,modComments)+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 hiding (Pattern) import GHC.Types.SourceText import GHC.Types.Name.Reader import GHC.Data.FastString@@ -72,7 +73,11 @@ listHint :: DeclHint listHint _ modu = listDecl overloadedListsOn where- exts = concatMap snd (languagePragmas (pragmas (modComments 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).+ exts = concatMap snd (languagePragmas (pragmas (modComments modu) ++ pragmas (firstDeclComments modu))) overloadedListsOn = "OverloadedLists" `elem` exts listDecl :: Bool -> LHsDecl GhcPs -> [Idea]@@ -99,9 +104,9 @@ 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@@ -111,9 +116,9 @@ | otherwise = [] where ys = moveGuardsForward xs- o' = noLocA $ ExplicitList EpAnnNotUsed []- o2 = noLocA $ HsDo EpAnnNotUsed ctx (noLocA (filter ((/= Just "True") . qualCon) xs ++ [e]))- o3 = noLocA $ HsDo EpAnnNotUsed ctx (noLocA $ 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)@@ -124,10 +129,11 @@ listCompCheckMap o mp f ctx stmts | varToStr mp == "map" = [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 = noLocA $ LastStmt noExtField (noLocA $ HsApp EpAnnNotUsed (paren f) (paren body)) b s- o2 =noLocA $ HsDo EpAnnNotUsed ctx (noLocA $ 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]@@ -158,7 +164,7 @@ listExp overloadedListsOn b (fromParen -> x) = if null res then concatMap (listExp overloadedListsOn $ isAppend x) $ children x- else [head res]+ else [NE.head $ NE.fromList res] where res = [suggest name (reLoc x) (reLoc x2) [r] | (name, f) <- checks overloadedListsOn@@ -166,7 +172,7 @@ , 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]+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]@@ -198,9 +204,9 @@ usePList :: LPat GhcPs -> Maybe (LPat GhcPs, [(String, R.SrcSpan)], String) usePList = fmap ( (\(e, s) ->- (noLocA (ListPat EpAnnNotUsed e)+ (noLocA (ListPat noAnn e) , map (fmap toRefactSrcSpan . fst) s- , unsafePrettyPrint (noLocA $ ListPat EpAnnNotUsed (map snd s) :: LPat GhcPs))+ , unsafePrettyPrint (noLocA $ ListPat noAnn (map snd s) :: LPat GhcPs)) ) . unzip )@@ -215,16 +221,16 @@ useString :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [a], String) useString b (L _ (ExplicitList _ xs)) | not $ null xs, Just s <- mapM fromChar xs =- let literal = noLocA (HsLit EpAnnNotUsed (HsString NoSourceText (fsLit (show s)))) :: LHsExpr GhcPs+ 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) ->- (noLocA (ExplicitList EpAnnNotUsed e)+ (noLocA (ExplicitList noAnn e) , map (fmap toSSA) s- , unsafePrettyPrint (noLocA $ ExplicitList EpAnnNotUsed (map snd s) :: LHsExpr GhcPs))+ , unsafePrettyPrint (noLocA $ ExplicitList noAnn (map snd s) :: LHsExpr GhcPs)) ) . unzip )@@ -254,24 +260,24 @@ f _ = Nothing gen :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs- gen x = noLocA . OpApp EpAnnNotUsed x (noLocA (HsVar noExtField (noLocA consDataCon_RDR)))+ gen x = noLocA . OpApp noExtField x (noLocA (HsVar noExtField (noLocA consDataCon_RDR))) useCons _ _ = Nothing typeListChar :: LHsType GhcPs typeListChar =- noLocA $ HsListTy EpAnnNotUsed- (noLocA (HsTyVar EpAnnNotUsed NotPromoted (noLocA (mkVarUnqual (fsLit "Char")))))+ noLocA $ HsListTy noAnn+ (noLocA (HsTyVar noAnn NotPromoted (noLocA (mkVarUnqual (fsLit "Char"))))) typeString :: LHsType GhcPs typeString =- noLocA $ HsTyVar EpAnnNotUsed NotPromoted (noLocA (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
src/Hint/ListRec.hs view
@@ -134,16 +134,16 @@ 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)] (EmptyLocalBinds _)}]})) ) =- [ noLocA $ BindStmt EpAnnNotUsed v lhs+ [ noLocA $ BindStmt noAnn v lhs , noLocA $ BodyStmt noExtField rhs noSyntaxExpr noSyntaxExpr ] asDo (L _ (HsDo _ (DoExpr _) (L _ stmts))) = stmts asDo x = [noLocA $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr]@@ -157,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.@@ -173,10 +173,10 @@ let ps12 = let (a, b) = splitAt p1 ps1 in map strToPat (a ++ xs : b) -- Function arguments. emptyLocalBinds = EmptyLocalBinds noExtField :: HsLocalBindsLR GhcPs GhcPs -- Empty where clause.- gRHS e = noLocA $ GRHS EpAnnNotUsed [] e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs.+ 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=EpAnnNotUsed,m_pats=ps12, m_grhss=gRHSSs e, ..} -- Match.- matchGroup e = MG{mg_alts=noLocA [noLocA $ match e], mg_origin=Generated, ..} -- Match group.+ 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), noLocA . ValD noExtField . funBind)@@ -212,7 +212,7 @@ , 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,7 +225,7 @@ readPat :: LPat GhcPs -> Maybe (Either String BList) readPat (view -> PVar_ x) = Just $ Left x-readPat (L _ (ParPat _ _ (L _ (ConPat _ (L _ n) (InfixCon (view -> PVar_ x) (view -> PVar_ xs)))) _))+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 [] []))) | n == nameRdrName nilDataConName = Just $ Right BNil
src/Hint/Match.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-} {-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts #-} @@ -43,8 +44,8 @@ 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@@ -52,7 +53,6 @@ import Config.Type import Data.Generics.Uniplate.DataOnly -import GHC.Data.Bag import GHC.Hs import GHC.Types.SrcLoc import GHC.Types.SourceText@@ -100,8 +100,8 @@ -- If a == b then -- x is 'a', op is '==' and y is 'b' and,- let lSec = addParen (L l (SectionL EpAnnNotUsed x op)) -- (a == )- rSec = addParen (L l (SectionR EpAnnNotUsed op y)) -- ( == b)+ let lSec = addParen (L l (SectionL noExtField x op)) -- (a == )+ rSec = addParen (L l (SectionR noExtField op y)) -- ( == b) in (first (lSec :) <$> dotVersion y) ++ (first (rSec :) <$> dotVersion x) -- [([(a ==)], b), ([(b == )], a])]. dotVersion _ = [] @@ -120,7 +120,7 @@ -- | 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 @@ -141,7 +141,7 @@ -- 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 $ noLocA (HsApp EpAnnNotUsed fun rhs)+ let rhs' | Just fun <- extra = rebracket1 $ noLocA (HsApp noExtField fun rhs) | otherwise = rhs (e, (tpl, substNoParens)) = substitute u rhs' noParens = [varToStr $ fromParen x | L _ (HsApp _ (varToStr -> "_noParen_") x) <- universe tpl]@@ -182,7 +182,7 @@ | varToStr op == "||" = bool x || bool y | varToStr op == "==" = expr (fromParen1 x) `astEq` expr (fromParen1 y) bool (L _ (HsApp _ x y)) | varToStr x == "not" = not $ bool y- bool (L _ (HsPar _ _ x _)) = bool x+ bool (L _ (HsPar _ x)) = bool x bool (L _ (HsApp _ cond (sub -> y))) | 'i' : 's' : typ <- varToStr cond = isType typ y@@ -200,7 +200,7 @@ 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@@ -219,7 +219,7 @@ typ == top asInt :: LHsExpr GhcPs -> Maybe Integer- asInt (L _ (HsPar _ _ x _)) = asInt x+ 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@@ -275,5 +275,5 @@ where f :: LHsType GhcPs -> LHsType GhcPs f (L _ (HsAppTy _ t x@(L _ HsAppTy{}))) =- noLocA (HsAppTy noExtField t (noLocA (HsParTy EpAnnNotUsed x)))+ noLocA (HsAppTy noExtField t (noLocA (HsParTy noAnn x))) f x = x
src/Hint/Monad.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-}@@ -76,8 +77,7 @@ import GHC.Types.Basic import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence-import GHC.Data.Bag-import qualified GHC.Data.Strict+import GHC.Data.Strict qualified import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr@@ -90,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]@@ -119,8 +119,8 @@ case x of (view -> App2 op x1 x2) | isTag ">>" op -> f x1 (view -> App2 op x1 (view -> LamConst1 _)) | isTag ">>=" op -> f x1- (L l (HsApp _ op x)) | isTag "void" op -> seenVoid (L l . HsApp EpAnnNotUsed op) x- (L l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (L l . OpApp EpAnnNotUsed op dol) x+ (L l (HsApp _ op x)) | isTag "void" op -> seenVoid (L l . HsApp noExtField op) x+ (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 (locA loc)) doOrMDo [Replace Expr (toSSA x) [("y", toSSA y)] "y"]@@ -128,14 +128,14 @@ , not $ doAsAvoidingIndentation parentDo x ] (L loc (HsDo _ (DoExpr mm) (L _ xs))) ->- monadSteps (L loc . HsDo EpAnnNotUsed (DoExpr mm) . noLocA) 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 (L l (HsPar x p y q)) = seenVoid (wrap . L l . \y -> HsPar x p y q) y+ 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]@@ -173,14 +173,14 @@ 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 anna _)))) (L _ (HsDo _ _ (L annb _)))- | SrcSpanAnn _ (RealSrcSpan a _) <- anna- , SrcSpanAnn _ (RealSrcSpan b _) <- annb- = srcSpanStartCol a == srcSpanStartCol b+ | 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@@ -189,9 +189,9 @@ modifyAppHead f = go id where go :: (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> (LHsExpr GhcPs, Maybe a)- go wrap (L l (HsPar _ p x q )) = go (wrap . L l . \x -> HsPar EpAnnNotUsed p x q) x- go wrap (L l (HsApp _ x y)) = go (\x -> wrap $ L l (HsApp EpAnnNotUsed x y)) x- go wrap (L l (OpApp _ x op y)) | isDol op = go (\x -> wrap $ L l (OpApp EpAnnNotUsed x op y)) x+ go wrap (L l (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)@@ -204,11 +204,11 @@ -- 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 . nlHsPar) x-monadNoResult inside wrap (L l (HsApp _ x y)) = monadNoResult inside (\x -> wrap $ L l (HsApp EpAnnNotUsed x y)) 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 EpAnnNotUsed x tag y)) x- | occNameStr op == ">>=" = monadNoResult inside (wrap . L l . OpApp EpAnnNotUsed x tag) y+ | isDol tag = monadNoResult inside (\x -> wrap $ L l (OpApp noExtField x tag y)) x+ | occNameStr op == ">>=" = monadNoResult inside (wrap . L l . OpApp noExtField x tag) y monadNoResult inside wrap x | x2 : _ <- filter (`isTag` x) badFuncs , let x3 = x2 ++ "_"@@ -234,7 +234,7 @@ -- 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 = noLocA $ HsApp EpAnnNotUsed (strToVar "join") x+ = let app = noLocA $ HsApp noExtField (strToVar "join") x body = noLocA $ BodyStmt noExtField (rebracket1 app) noSyntaxExpr noSyntaxExpr stmts = body : xs in [warn "Use join" (reLoc (wrap o)) (reLoc (wrap stmts)) r]@@ -260,7 +260,7 @@ , 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 <$>" (reLoc (wrap o)) (reLoc (wrap [noLocA $ BodyStmt noExtField (noLocA $ OpApp EpAnnNotUsed (foldl' (\acc e -> noLocA $ OpApp EpAnnNotUsed acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr]))+ [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)@@ -294,14 +294,14 @@ template :: String -> LHsExpr GhcPs -> ExprLStmt GhcPs template lhs rhs = let p = noLocA $ mkRdrUnqual (mkVarOcc lhs)- grhs = noLocA (GRHS EpAnnNotUsed [] rhs)+ grhs = noLocA (GRHS noAnn [] rhs) grhss = GRHSs emptyComments [grhs] (EmptyLocalBinds noExtField)- match = noLocA $ Match EpAnnNotUsed (FunRhs p Prefix NoSrcStrict) [] grhss- fb = noLocA $ FunBind noExtField p (MG noExtField (noLocA [match]) Generated) []- binds = unitBag fb+ 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 EpAnnNotUsed valBinds- in noLocA $ LetStmt EpAnnNotUsed localBinds+ 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)@@ -309,7 +309,7 @@ fromApplies x = ([], x) 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 $ noLocA (HsApp EpAnnNotUsed x z)+fromRet (L _ (HsPar _ x)) = fromRet x+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,10 +45,11 @@ 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@@ -85,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 @@ -100,20 +102,23 @@ L locGRHS (GRHS ttg0 guards (L locExpr dots)) where dots :: HsExpr GhcPs- dots = HsLit EpAnnNotUsed (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- getConNames' XConDecl{} = []+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` "_'"
+ 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
@@ -72,12 +72,11 @@ shouldSuggestStrategies dataDef = not (isData dataDef) && not (hasAllStrategies dataDef) hasAllStrategies :: HsDataDefn GhcPs -> Bool-hasAllStrategies (HsDataDefn _ NewType _ _ _ _ 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,31 +97,39 @@ 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 }+ 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 $ 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')@@ -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
src/Hint/NumLiteral.hs view
@@ -4,6 +4,8 @@ <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@@ -20,37 +22,46 @@ 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)+import Hint.Type (DeclHint, toSSA, modComments, firstDeclComments) import Idea (Idea, suggest) numLiteralHint :: DeclHint numLiteralHint _ modu =- if NumericUnderscores `elem` extensions (modComments modu) then+ -- 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` srcTxt, srcTxt /= underscoredSrcTxt ]+ [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` unpackFS srcTxt, unpackFS srcTxt /= underscoredSrcTxt ] where- underscoredSrcTxt = addUnderscore srcTxt- y = noLocA $ HsOverLit EpAnnNotUsed $ ol{ol_val = HsIntegral intLit{il_text = SourceText underscoredSrcTxt}}+ 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` srcTxt, srcTxt /= underscoredSrcTxt ]+ [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` unpackFS srcTxt, unpackFS srcTxt /= underscoredSrcTxt ] where- underscoredSrcTxt = addUnderscore srcTxt- y = noLocA $ HsOverLit EpAnnNotUsed $ ol{ol_val = HsFractional fracLit{fl_text = SourceText underscoredSrcTxt}}+ 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 @@ -65,7 +76,9 @@ chunkSize = if null (nl_prefix numLit) then 3 else 4 underscore chunkSize = intercalate "_" . chunk chunkSize- underscoreFromRight chunkSize = reverse . underscore chunkSize . reverse+ 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
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,modComments,ideaTo,toSSA,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,15 +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 hiding (Pattern)-import qualified GHC.Data.Strict+import GHC.Data.Strict qualified import GHC.Util import Language.Haskell.GhclibParserEx.GHC.Hs.Pat@@ -91,7 +91,12 @@ concatMap (patHint strict True) (universeBi $ transformBi noPatBind x) ++ concatMap expHint (universeBi x) where- exts = nubOrd $ concatMap snd (languagePragmas (pragmas (modComments 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@@ -118,7 +123,7 @@ rawGuards = asGuards bod mkGuard :: LHsExpr GhcPs -> (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs))- mkGuard a = GRHS EpAnnNotUsed [noLocA $ BodyStmt noExtField a noSyntaxExpr noSyntaxExpr]+ mkGuard a = GRHS noAnn [noLocA $ BodyStmt noExtField a noSyntaxExpr noSyntaxExpr] guards :: [LGRHS GhcPs (LHsExpr GhcPs)] guards = map (noLocA . uncurry mkGuard) rawGuards@@ -152,12 +157,12 @@ 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=[noLocA (GRHS EpAnnNotUsed [] bod)]}) [Delete Stmt (toSSA 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 :: HsLocalBinds GhcPs -> Bool- f (HsValBinds _ (ValBinds _ bag _)) = isEmptyBag bag+ f (HsValBinds _ (ValBinds _ l _)) = null l f (HsIPBinds _ (IPBinds _ l)) = null l f _ = False whereSpan = case l of@@ -169,11 +174,11 @@ hints gen (Pattern l t pats o@(GRHSs _ (unsnoc -> Just (gs, L _ (GRHS _ [test] bod))) binds)) | unsafePrettyPrint test == "True" = let otherwise_ = noLocA $ BodyStmt noExtField (strToVar "otherwise") noSyntaxExpr noSyntaxExpr in- [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLocA (GRHS EpAnnNotUsed [otherwise_] bod)]}) [Replace Expr (toSSA test) [] "otherwise"]]+ [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)]-asGuards (L _ (HsPar _ _ x _)) = asGuards x+asGuards (L _ (HsPar _ x)) = asGuards x asGuards (L _ (HsIf _ a b c)) = (a, b) : asGuards c asGuards x = [(strToVar "otherwise", x)] @@ -184,20 +189,20 @@ 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 (locA loc) Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest msg (noLoc o :: Located (HsBind GhcPs)) (noLoc (PatBind EpAnnNotUsed pat rhs ([], [])) :: Located (HsBind 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 (locA loc) R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest msg (reLoc o) (noLoc (Match EpAnnNotUsed ctx pats grhss) :: Located (Match 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))) | length args >= 3 && all isPWildcard args =- let rec_fields = HsRecFields [] Nothing :: HsRecFields GhcPs (LPat GhcPs)- new = noLocA $ ConPat EpAnnNotUsed 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" (reLoc o) (reLoc new) [Replace R.Pattern (toSSA o) [] (unsafePrettyPrint new)]] patHint _ _ o@(L _ (VarPat _ (L _ name)))@@ -207,7 +212,7 @@ | 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+ f (ParPat _ (L _ x)) = f x f (AsPat _ _ (L _ x)) = f x f LitPat {} = True f NPat {} = True@@ -221,7 +226,7 @@ | 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+ f (ParPat _ (L _ x)) = f x f (AsPat _ _ (L _ x)) = f x f WildPat{} = True f VarPat{} = True@@ -233,11 +238,11 @@ 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)] (EmptyLocalBinds _))) ]) FromSource ))) =+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 (toSSA o) [("x", toSSA e)] "x"-expHint o@(L _ (HsCase _ (L _ (HsVar _ (L _ x))) (MG _ (L _ [L _ (Match _ CaseAlt [L _ (VarPat _ (L _ y))] (GRHSs _ [L _ (GRHS _ [] e)] (EmptyLocalBinds _))) ]) FromSource )))+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" (reLoc o) (reLoc e) [r]] where
src/Hint/Pragma.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} @@ -32,12 +33,12 @@ module Hint.Pragma(pragmaHint) where -import Hint.Type(ModuHint,Idea(..),Severity(..),toSSAnc,rawIdea,modComments)+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.Hs import GHC.Types.SrcLoc@@ -48,7 +49,11 @@ pragmaHint :: ModuHint pragmaHint _ modu =- let ps = pragmas (modComments 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@@ -139,7 +144,7 @@ -- '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,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}@@ -20,16 +21,17 @@ </TEST> -} -import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),warn,rawIdea,modComments)+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@@ -41,7 +43,6 @@ import GHC.Hs import GHC.Types.Name.Reader-import GHC.Unit.Module import GHC.Types.SrcLoc import GHC.Types.Name.Occurrence import Language.Haskell.GhclibParserEx.GHC.Hs@@ -51,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 = modComments 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 ++@@ -151,6 +158,11 @@ , 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 lImportDecls (def, mp) = mapMaybe getImportHint lImportDecls where@@ -162,7 +174,7 @@ Left $ ideaNoTo $ warn "Avoid restricted module" (reLoc i) (reLoc i) [] let importedIdents = Set.fromList $- case ideclHiding of+ case first (== EverythingBut) <$> ideclImportList of Just (False, lxs) -> concatMap (importListToIdents . unLoc) (unLoc lxs) _ -> [] invalidIdents = case riRestrictIdents of@@ -184,31 +196,38 @@ case fromMaybe ImportStyleUnrestricted $ getAlt riImportStyle of ImportStyleUnrestricted | NotQualified <- ideclQualified -> (Nothing, Nothing)- | otherwise -> (second (<> " or unqualified") <$> expectedQualStyle, Nothing)- ImportStyleQualified -> (expectedQualStyleDef, Nothing)+ | otherwise -> (Just $ second (<> " or unqualified") expectedQualStyle, Nothing)+ ImportStyleQualified -> (Just expectedQualStyle, Nothing) ImportStyleExplicitOrQualified- | Just (False, _) <- ideclHiding -> (Nothing, Nothing)+ | Just (False, _) <- first (== EverythingBut) <$> ideclImportList -> (Nothing, Nothing) | otherwise ->- ( second (<> " or with an explicit import list") <$> expectedQualStyleDef+ ( Just $ second (<> " or with an explicit import list") expectedQualStyle , Nothing ) ImportStyleExplicit- | Just (False, _) <- ideclHiding -> (Nothing, Nothing)+ | Just (False, _) <- first (== EverythingBut) <$> ideclImportList -> (Nothing, Nothing) | otherwise ->- ( Just (NotQualified, "unqualified")- , Just $ Just (False, noLocA []) )- ImportStyleUnqualified -> (Just (NotQualified, "unqualified"), Nothing)- expectedQualStyleDef = expectedQualStyle <|> Just (QualifiedPre, "qualified")+ ( Just (Right NotQualified, "unqualified")+ , Just $ Just (Exactly, noLocA []) )+ ImportStyleUnqualified -> (Just (Right NotQualified, "unqualified"), Nothing) expectedQualStyle = case fromMaybe QualifiedStyleUnrestricted $ getAlt riQualifiedStyle of- QualifiedStyleUnrestricted -> Nothing- QualifiedStylePost -> Just (QualifiedPost, "post-qualified")- QualifiedStylePre -> Just (QualifiedPre, "pre-qualified")+ 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- | Just ideclQualified == (fst <$> expectedQual) = Nothing+ -- 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- let i' = noLoc $ (unLoc i){ ideclQualified = qual- , ideclHiding = fromMaybe ideclHiding expectedHiding }+ -- 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' [] @@ -231,16 +250,16 @@ 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 :: LIEWrappedName GhcPs -> Maybe String fromName wrapped = case unLoc wrapped of- IEName n -> fromId (unLoc n)+ IEName _ n -> fromId (unLoc n) IEPattern _ n -> ("pattern " ++) <$> fromId (unLoc n) IEType _ n -> ("type " ++) <$> fromId (unLoc n) @@ -252,7 +271,7 @@ checkFunctions :: Scope -> String -> [LHsDecl GhcPs] -> RestrictFunctions -> [Idea] checkFunctions scope modu decls (def, mp) =- [ (ideaMessage message $ ideaNoTo $ warn "Avoid restricted function" (reLocN x) (reLocN 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 :: [LocatedN RdrName]
src/Hint/Smell.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} module Hint.Smell (smellModuleHint,smellHint) where @@ -80,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.Data.Bag import GHC.Types.SrcLoc+import GHC.Types.Name.Reader import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable smellModuleHint :: [Setting] -> ModuHint@@ -128,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]@@ -141,7 +142,7 @@ 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 _))) = [(locA l, rawIdea Config.Type.Warning "Long function" (locA l) (showSDocUnsafe (pprGRHS ctx r)) Nothing [] [])]@@ -149,7 +150,7 @@ -- The spans of a 'where' clause are the spans of its bindings. whereSpans :: HsLocalBinds GhcPs -> [(SrcSpan, Idea)] whereSpans (HsValBinds _ (ValBinds _ bs _)) =- concatMap (declSpans . (\(L loc bind) -> L loc (ValD noExtField bind))) (bagToList bs)+ concatMap (declSpans . (\(L loc bind) -> L loc (ValD noExtField bind))) bs whereSpans _ = [] spanLength :: SrcSpan -> Int
src/Hint/Unsafe.hs view
@@ -54,23 +54,26 @@ -- '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 = noLocA $- SigD noExtField (InlineSig EpAnnNotUsed (noLocA (mkRdrUnqual x))- (InlinePragma (SourceText "{-# NOINLINE") (NoInline (SourceText "{-# NOINLINE")) Nothing NeverActive FunLike))+ 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 (SourceText "{-# 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@@ -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,7 +50,7 @@ import System.FilePath import Data.Functor import Prelude-import qualified Hint.Restrict as Restrict+import Hint.Restrict qualified as Restrict -- | Get the Cabal configured data directory of HLint.@@ -57,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: --@@ -144,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,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} module Refact@@ -9,6 +10,7 @@ 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,10 @@ 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 qualified GHC.Parser.Annotation as GHC+import GHC.Types.SrcLoc qualified as GHC+import GHC.Parser.Annotation qualified as GHC import GHC.Util.SrcLoc (getAncLoc) @@ -42,10 +44,10 @@ toSS :: GHC.Located a -> R.SrcSpan toSS = toRefactSrcSpan . GHC.getLoc -toSSA :: GHC.GenLocated (GHC.SrcSpanAnn' a) e -> R.SrcSpan+toSSA :: GHC.GenLocated (GHC.EpAnn a) e -> R.SrcSpan toSSA = toRefactSrcSpan . GHC.getLocA -toSSAnc :: GHC.GenLocated GHC.Anchor e -> R.SrcSpan+toSSAnc :: GHC.GenLocated GHC.NoCommentsLocation e -> R.SrcSpan toSSAnc = toRefactSrcSpan . getAncLoc checkRefactor :: Maybe FilePath -> IO FilePath@@ -57,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,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-}@@ -5,9 +6,10 @@ 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 @@ -120,7 +122,7 @@ ++ ["", "# All LHS/RHS hints"] ++ (mkLine <$> sortDedup (hintRuleName <$> sLhsRhsRules)) where- sortDedup = fmap head . group . sort+ sortDedup = fmap (NE.head . NE.fromList) . group . sort mkLine name = "- " <> show severity <> ": {name: " <> jsonToString name <> "}" genSummaryMd :: Summary -> String@@ -160,7 +162,7 @@ where row1 = row $ [ "<td>" ++ hName ++ "</td>", "<td>"]- ++ showExample (head hExamples)+ ++ showExample (NE.head (NE.fromList hExamples)) ++ ["Does not support refactoring." | not hRefactoring] ++ ["</td>"] ++ [ "<td>" ++ show hSeverity ++ "</td>"
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@@ -163,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
tests/cpp.test view
@@ -44,7 +44,8 @@ main = undefined EXIT 1 OUTPUT-tests/cpp-ext-enable.hs:1:1: Error: Parse error: tests/cpp-ext-enable.hs:3:14: 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 #-} @@ -52,7 +53,7 @@ main = undefined -1 hint+1 error --------------------------------------------------------------------- RUN tests/cpp-ext-disable.hs@@ -128,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/import_style.test view
@@ -66,3 +66,64 @@ 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/lhs.test view
@@ -31,7 +31,7 @@ > -1 hint+1 error --------------------------------------------------------------------- RUN tests/lhs-first-line.lhs
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: tests/ignore-parse-error3.hs:1:14: error:+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
@@ -40,7 +40,6 @@ [("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 = ""}])] - --------------------------------------------------------------------- RUN tests/serialise-five.hs --serialise FILE tests/serialise-five.hs