hlint 3.4.1 → 3.5
raw patch · 33 files changed
+257/−168 lines, 33 filesdep ~ghcdep ~ghc-lib-parserdep ~ghc-lib-parser-ex
Dependency ranges changed: ghc, ghc-lib-parser, ghc-lib-parser-ex
Files
- CHANGES.txt +18/−0
- README.md +2/−0
- data/hlint.yaml +62/−12
- hlint.cabal +7/−7
- src/Config/Compute.hs +2/−2
- src/Config/Haskell.hs +3/−2
- src/Config/Yaml.hs +4/−2
- src/GHC/All.hs +6/−4
- src/GHC/Util/ApiAnnotation.hs +5/−7
- src/GHC/Util/Brackets.hs +9/−8
- src/GHC/Util/FreeVars.hs +16/−20
- src/GHC/Util/HsExpr.hs +8/−8
- src/GHC/Util/Scope.hs +5/−1
- src/GHC/Util/SrcLoc.hs +8/−1
- src/GHC/Util/Unify.hs +4/−3
- src/GHC/Util/View.hs +1/−1
- src/Hint/Bracket.hs +10/−11
- src/Hint/Comment.hs +2/−1
- src/Hint/Extensions.hs +27/−30
- src/Hint/Import.hs +8/−1
- src/Hint/Lambda.hs +10/−10
- src/Hint/List.hs +3/−3
- src/Hint/ListRec.hs +2/−2
- src/Hint/Match.hs +6/−6
- src/Hint/Monad.hs +8/−6
- src/Hint/NewType.hs +1/−1
- src/Hint/NumLiteral.hs +2/−2
- src/Hint/Pattern.hs +10/−9
- src/Hint/Pragma.hs +1/−1
- src/Hint/Unsafe.hs +2/−2
- tests/cpp.test +1/−2
- tests/parse-error.test +2/−2
- tests/serialise.test +2/−1
CHANGES.txt view
@@ -1,5 +1,23 @@ Changelog for HLint (* = breaking change) +3.5, released 2022-09-20+ #1421, change zip/repeat to map with tuple section+ #1418, add more QuickCheck hints+ #1420, suggest use of Data.Tuple.Extra.both in the extra hints+ #1407, fix some list-comp hints that applied too broadly+ #1407, suggest [ f x | x <- [y] ] to [f y]+ #1417, add some more isAlpha/isDigit suggestions+ #1411, add some empty list equivalent to "" hints+ #1416, add hints for (== True) and other bool/section values+ #1410, remove support for building with GHC 8.10+* #1410, always default to using ghc-parser instead of the GHC API+* #1410, upgrade to the GHC 9.4 parse tree+ #1408, evaluate calls of map with empty/singleton lists+ #1409, add notNull hints, e.g. notNull . concat ==> any notNull+ #1406, spot list comprehension that should be lefts/rights+ #1404, add more if/then/else to min or max hints+ #1403, add last . reverse ==> head+ #1397, evaluation rules for minimum/maximum on singleton lists 3.4.1, released 2022-07-10 #1345, add --generate-config to generate a complete config #1345, add --generate-summary-json
README.md view
@@ -21,6 +21,7 @@ * HLint turns on many language extensions so it can parse more documents, occasionally some break otherwise legal syntax - e.g. `{-#INLINE foo#-}` doesn't work with `MagicHash`, `foo $bar` means something different with `TemplateHaskell`. These extensions can be disabled with `-XNoMagicHash` or `-XNoTemplateHaskell` etc. * HLint doesn't run any custom preprocessors, e.g. [markdown-unlit](https://hackage.haskell.org/package/markdown-unlit) or [record-dot-preprocessor](https://hackage.haskell.org/package/record-dot-preprocessor), so code making use of them will usually fail to parse. * Some hints, like `Use const`, don't work for non-lifted (i.e. unlifted and unboxed) types.+* Some language extensions like `Strict` can cause certain hints (e.g. eta reduction) to be incorrect. ## Installing and running HLint @@ -96,6 +97,7 @@ * [hlint-test](https://hackage.haskell.org/package/hlint-test) helps you write a small test runner with HLint. * [hint-man](https://github.com/apps/hint-man) automatically submits reviews to opened pull requests in your repositories with inline hints. * [CircleCI](https://circleci.com/orbs/registry/orb/haskell-works/hlint) has a plugin to run HLint more easily.+* [haskell/actions](https://github.com/haskell/actions) has `hlint-setup` and `hlint-run` actions for GitHub. ### Automatically Applying Hints
data/hlint.yaml view
@@ -120,9 +120,13 @@ - 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} - warn: {lhs: if a >= b then a else b, rhs: max a b}+ - warn: {lhs: if a >= b then b else a, rhs: min a b} - warn: {lhs: if a > b then a else b, rhs: max a b}+ - warn: {lhs: if a > b then b else a, rhs: min a b} - warn: {lhs: if a <= b then a else b, rhs: min a b}+ - warn: {lhs: if a <= b then b else a, rhs: max a b} - warn: {lhs: if a < b then a else b, rhs: min a b}+ - warn: {lhs: if a < b then b else a, rhs: max a b} - warn: {lhs: "maximum [a, b]", rhs: max a b} - warn: {lhs: "minimum [a, b]", rhs: min a b} @@ -130,6 +134,7 @@ # READ/SHOW - warn: {lhs: showsPrec 0 x "", rhs: show x}+ - warn: {lhs: "showsPrec 0 x []", rhs: show x} - warn: {lhs: readsPrec 0, rhs: reads} - warn: {lhs: showsPrec 0, rhs: shows} - hint: {lhs: showIntAtBase 16 intToDigit, rhs: showHex}@@ -149,6 +154,7 @@ - warn: {lhs: map f (repeat x), rhs: repeat (f x)} - warn: {lhs: "cycle [x]", rhs: repeat x} - warn: {lhs: head (reverse x), rhs: last x}+ - warn: {lhs: last (reverse x), rhs: head x, note: IncreasesLaziness} - warn: {lhs: head (drop n x), rhs: x !! n, side: isNat n} - warn: {lhs: head (drop n x), rhs: x !! max 0 n, side: not (isNat n) && not (isNeg n)} - warn: {lhs: reverse (init x), rhs: tail (reverse x)}@@ -248,7 +254,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: 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: 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}@@ -356,10 +364,14 @@ # CHAR - - warn: {lhs: a >= 'a' && a <= 'z', rhs: isAsciiLower a}- - warn: {lhs: a >= 'A' && a <= 'Z', rhs: isAsciiUpper a}- - warn: {lhs: a >= '0' && a <= '9', rhs: isDigit a}- - warn: {lhs: a >= '0' && a <= '7', rhs: isOctDigit a}+ - warn: {lhs: "a >= 'a' && a <= 'z'", rhs: isAsciiLower a}+ - warn: {lhs: "'a' <= a && a <= 'z'", rhs: isAsciiLower a}+ - warn: {lhs: "a >= 'A' && a <= 'Z'", rhs: isAsciiUpper a}+ - warn: {lhs: "'A' <= a && a <= 'Z'", rhs: isAsciiUpper a}+ - warn: {lhs: "a >= '0' && a <= '9'", rhs: isDigit a}+ - warn: {lhs: "'0' <= a && a <= '9'", rhs: isDigit a}+ - warn: {lhs: "a >= '0' && a <= '7'", rhs: isOctDigit a}+ - warn: {lhs: "'0' <= a && a <= '7'", rhs: isOctDigit a} - warn: {lhs: isLower a || isUpper a, rhs: isAlpha a} - warn: {lhs: isUpper a || isLower a, rhs: isAlpha a} @@ -369,10 +381,18 @@ - hint: {lhs: x == False, rhs: not x, name: Redundant ==} - warn: {lhs: True == a, rhs: a, name: Redundant ==} - hint: {lhs: False == a, rhs: not a, name: Redundant ==}+ - hint: {lhs: (== True), rhs: id, name: Redundant ==}+ - hint: {lhs: (== False), rhs: not, name: Redundant ==}+ - hint: {lhs: (True ==), rhs: id, name: Redundant ==}+ - hint: {lhs: (False ==), rhs: not, name: Redundant ==} - warn: {lhs: a /= True, rhs: not a, name: Redundant /=} - hint: {lhs: a /= False, rhs: a, name: Redundant /=} - warn: {lhs: True /= a, rhs: not a, name: Redundant /=} - hint: {lhs: False /= a, rhs: a, name: Redundant /=}+ - hint: {lhs: (/= True), rhs: not, name: Redundant /=}+ - hint: {lhs: (/= False), rhs: id, name: Redundant /=}+ - hint: {lhs: (True /=), rhs: not, name: Redundant /=}+ - hint: {lhs: (False /=), rhs: id, name: Redundant /=} - warn: {lhs: if a then x else x, rhs: x, note: IncreasesLaziness, name: Redundant if} - warn: {lhs: if a then True else False, rhs: a, name: Redundant if} - warn: {lhs: if a then False else True, rhs: not a, name: Redundant if}@@ -498,8 +518,6 @@ - warn: {lhs: unless (not x), rhs: when x} - warn: {lhs: x >>= id, rhs: Control.Monad.join x} - warn: {lhs: id =<< x, rhs: Control.Monad.join x}- - warn: {lhs: id =<< x, rhs: Control.Monad.join x}- - warn: {lhs: id =<< x, rhs: Control.Monad.join x} - hint: {lhs: join (f <$> x), rhs: f =<< x} - hint: {lhs: join (fmap f x), rhs: f =<< x} - hint: {lhs: a >> pure (), rhs: Control.Monad.void a, side: isAtom a || isApp a}@@ -587,6 +605,7 @@ - hint: {lhs: "if b then [x] else []", rhs: "[x | b]", name: Use list comprehension} - hint: {lhs: "if b then [] else [x]", rhs: "[x | not b]", name: Use list comprehension} - hint: {lhs: "[x | x <- y]", rhs: "y", side: isVar x, name: Redundant list comprehension}+ - hint: {lhs: "[ f x | x <- [y] ]", rhs: "[f y]", side: isVar x, name: Redundant list comprehension} # SEQ @@ -649,7 +668,7 @@ - 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: mapMaybe id, rhs: catMaybes}- - hint: {lhs: "[x | Just x <- a]", rhs: Data.Maybe.catMaybes a}+ - hint: {lhs: "[x | Just x <- a]", rhs: Data.Maybe.catMaybes a, side: isVar x} - hint: {lhs: case m of Nothing -> Nothing; Just x -> x, rhs: Control.Monad.join m} - hint: {lhs: maybe Nothing id, rhs: join} - hint: {lhs: maybe Nothing f x, rhs: f =<< x}@@ -679,8 +698,8 @@ # EITHER - - warn: {lhs: "[a | Left a <- a]", rhs: lefts a}- - warn: {lhs: "[a | Right a <- a]", rhs: rights a}+ - warn: {lhs: "[a | Left a <- b]", rhs: lefts b, side: isVar a}+ - warn: {lhs: "[a | Right a <- b]", rhs: rights b, side: isVar a} - warn: {lhs: either Left (Right . f), rhs: fmap f} - warn: {lhs: either f g (fmap h x), rhs: either f (g . h) x, name: Redundant fmap} - warn: {lhs: isLeft (fmap f x), rhs: isLeft x}@@ -809,7 +828,9 @@ - warn: {lhs: "init [x]", rhs: "[]", name: Evaluate} - warn: {lhs: "null [x]", rhs: "False", name: Evaluate} - warn: {lhs: "null []", rhs: "True", name: Evaluate}+ - warn: {lhs: "null \"\"", rhs: "True", name: Evaluate} - warn: {lhs: "length []", rhs: "0", name: Evaluate}+ - warn: {lhs: "length \"\"", rhs: "0", name: Evaluate} - warn: {lhs: "foldl f z []", rhs: z, name: Evaluate} - warn: {lhs: "foldr f z []", rhs: z, name: Evaluate} - warn: {lhs: "foldr1 f [x]", rhs: x, name: Evaluate}@@ -817,11 +838,17 @@ - warn: {lhs: "scanr1 f []", rhs: "[]", name: Evaluate} - warn: {lhs: "scanr1 f [x]", rhs: "[x]", name: Evaluate} - warn: {lhs: "take n []", rhs: "[]", note: IncreasesLaziness, name: Evaluate}+ - warn: {lhs: "take n \"\"", rhs: "\"\"", note: IncreasesLaziness, name: Evaluate} - warn: {lhs: "drop n []", rhs: "[]", note: IncreasesLaziness, name: Evaluate}+ - warn: {lhs: "drop n \"\"", rhs: "\"\"", note: IncreasesLaziness, name: Evaluate} - warn: {lhs: "takeWhile p []", rhs: "[]", name: Evaluate}+ - warn: {lhs: "takeWhile p \"\"", rhs: "\"\"", name: Evaluate} - warn: {lhs: "dropWhile p []", rhs: "[]", name: Evaluate}+ - warn: {lhs: "dropWhile p \"\"", rhs: "\"\"", name: Evaluate} - warn: {lhs: "span p []", rhs: "([],[])", name: Evaluate}- - warn: {lhs: lines "", rhs: "[]", name: Evaluate}+ - warn: {lhs: "span p \"\"", rhs: "(\"\",\"\")", name: Evaluate}+ - warn: {lhs: "lines \"\"", rhs: "[]", name: Evaluate}+ - warn: {lhs: "lines []", rhs: "[]", name: Evaluate} - warn: {lhs: "unwords []", rhs: "\"\"", name: Evaluate} - warn: {lhs: x - 0, rhs: x, name: Evaluate} - warn: {lhs: x * 1, rhs: x, name: Evaluate}@@ -833,11 +860,17 @@ - warn: {lhs: any (const False), rhs: const False, note: IncreasesLaziness, name: Evaluate} - warn: {lhs: all (const True), rhs: const True, note: IncreasesLaziness, name: Evaluate} - warn: {lhs: "[] ++ x", rhs: x, name: Evaluate}+ - warn: {lhs: "\"\" ++ x", rhs: x, name: Evaluate} - warn: {lhs: "x ++ []", rhs: x, name: Evaluate}+ - warn: {lhs: "x ++ \"\"", rhs: x, name: Evaluate} - warn: {lhs: "all f [a]", rhs: f a, name: Evaluate} - warn: {lhs: "all f []", rhs: "True", name: Evaluate} - warn: {lhs: "any f [a]", rhs: f a, name: Evaluate} - warn: {lhs: "any f []", rhs: "False", name: Evaluate}+ - warn: {lhs: "maximum [a]", rhs: a, name: Evaluate}+ - warn: {lhs: "minimum [a]", rhs: a, name: Evaluate}+ - warn: {lhs: "map f []", rhs: "[]", name: Evaluate}+ - warn: {lhs: "map f [a]", rhs: "[f a]", name: Evaluate} # FOLDABLE + TUPLES @@ -949,7 +982,16 @@ - package base - package quickcheck rules:+ - warn: {lhs: "Test.QuickCheck.choose (x,x)", rhs: return x}+ - warn: {lhs: "Test.QuickCheck.chooseInt (x,x)", rhs: return x}+ - warn: {lhs: "Test.QuickCheck.chooseInteger (x,x)", rhs: return x}+ - warn: {lhs: "Test.QuickCheck.chooseBoundedIntegral (x,x)", rhs: return x}+ - warn: {lhs: "Test.QuickCheck.chooseEnum (x,x)", rhs: return x} - warn: {lhs: Control.Monad.join (Test.QuickCheck.elements l), rhs: Test.QuickCheck.oneof l}+ - warn: {lhs: "Test.QuickCheck.elements [x]", rhs: "return x"}+ - warn: {lhs: "Test.QuickCheck.growingElements [x]", rhs: "return x"}+ - warn: {lhs: "Test.QuickCheck.oneof [x]", rhs: "x", name: Evaluate}+ - warn: {lhs: "Test.QuickCheck.frequency [(a,x)]", rhs: "x", name: Evaluate} - group: name: generalise@@ -961,7 +1003,9 @@ - warn: {lhs: a ++ b, rhs: a <> b} - warn: {lhs: "sequence [a]", rhs: "pure <$> a"} - warn: {lhs: "x /= []", rhs: not (null x), name: Use null}+ - warn: {lhs: "x /= \"\"", rhs: not (null x), name: Use null} - warn: {lhs: "[] /= x", rhs: not (null x), name: Use null}+ - warn: {lhs: "\"\" /= x", rhs: not (null x), name: Use null} - warn: {lhs: "maybe []", rhs: foldMap} - group:@@ -1060,6 +1104,7 @@ - warn: {lhs: "nubOrdBy compare", rhs: "nubOrd"} - warn: {lhs: "\\a -> (a, a)", rhs: "dupe"} - warn: {lhs: "showFFloat (Just a) b \"\"", rhs: "showDP a b"}+ - warn: {lhs: "showFFloat (Just a) b []", rhs: "showDP a b"} - warn: {lhs: "readFileEncoding utf8", rhs: "readFileUTF8"} - warn: {lhs: "withFile a ReadMode hGetContents'", rhs: "readFile' a"} - warn: {lhs: "readFileEncoding' utf8", rhs: "readFileUTF8'"}@@ -1069,6 +1114,11 @@ - warn: {lhs: "last $ x : y", rhs: "lastDef x y"} - warn: {lhs: "drop 1", rhs: "drop1"} - warn: {lhs: "dropEnd 1", rhs: "dropEnd1"}+ - warn: {lhs: notNull (concat x), rhs: any notNull 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}+ - hint: {lhs: "\\(x,y) -> (f x, f y)", rhs: both f} # hints that will be enabled in future - group:@@ -1130,8 +1180,8 @@ - hint: {lhs: "[] /= x", rhs: not (null x), name: Use null} - hint: {lhs: "not (x || y)", rhs: "not x && not y", name: Apply De Morgan law} - hint: {lhs: "not (x && y)", rhs: "not x || not y", name: Apply De Morgan law}- - hint: {lhs: "[ f x | x <- l ]", rhs: map f l}- - hint: {lhs: "[ x | x <- l, p x ]", rhs: filter p l}+ - hint: {lhs: "[ f x | x <- l ]", rhs: map f l, side: isVar x}+ - hint: {lhs: "[ x | x <- l, p x ]", rhs: filter p l, side: isVar x} - warn: {lhs: foldr f c (reverse x), rhs: foldl (flip f) c x, name: Use left fold instead of right fold} - warn: {lhs: foldr1 f (reverse x), rhs: foldl1 (flip f) x, name: Use left fold instead of right fold} - warn: {lhs: foldl f c (reverse x), rhs: foldr (flip f) c x, note: IncreasesLaziness, name: Use right fold instead of left fold}
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version: 1.18 build-type: Simple name: hlint-version: 3.4.1+version: 3.5 license: BSD3 license-file: LICENSE category: Development@@ -36,7 +36,7 @@ extra-doc-files: README.md CHANGES.txt-tested-with: GHC==9.0, GHC==8.10, GHC==8.8+tested-with: GHC==9.2, GHC==9.0 source-repository head type: git@@ -53,7 +53,7 @@ description: Use GPL libraries, specifically hscolour flag ghc-lib- default: False+ default: True manual: True description: Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported @@ -81,16 +81,16 @@ deriving-aeson >= 0.2, filepattern >= 0.1.1 - if !flag(ghc-lib) && impl(ghc >= 9.2.2) && impl(ghc < 9.3.0)+ if !flag(ghc-lib) && impl(ghc >= 9.4.1) && impl(ghc < 9.5.0) build-depends:- ghc == 9.2.*,+ ghc == 9.4.*, ghc-boot-th, ghc-boot else build-depends:- ghc-lib-parser == 9.2.*+ ghc-lib-parser == 9.4.* build-depends:- ghc-lib-parser-ex >= 9.2.0.3 && < 9.2.1+ ghc-lib-parser-ex >= 9.4.0.0 && < 9.4.1 if flag(gpl) build-depends: hscolour >= 1.21
src/Config/Compute.hs view
@@ -63,7 +63,7 @@ findExp name vs HsLam{} = [] findExp name vs HsVar{} = [] findExp name vs (OpApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $- HsApp EpAnnNotUsed x $ noLocA $ HsPar EpAnnNotUsed $ noLocA $ HsApp EpAnnNotUsed y $ noLocA $ mkVar "_hlint"+ HsApp EpAnnNotUsed x $ nlHsPar $ noLocA $ HsApp EpAnnNotUsed y $ noLocA $ mkVar "_hlint" findExp name vs bod = [SettingMatchExp $ HintRule Warning defaultHintName []@@ -74,7 +74,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 $ noLocA $ HsPar EpAnnNotUsed y+ f (OpApp _ x dol y) | isDol dol = HsApp EpAnnNotUsed x $ nlHsPar y f x = x
src/Config/Haskell.hs view
@@ -23,6 +23,7 @@ import GHC.Data.FastString import GHC.Parser.Annotation import GHC.Utils.Outputable+import qualified GHC.Data.Strict import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader@@ -43,7 +44,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 @@ -83,6 +84,6 @@ errorOnComment :: LEpaComment -> String -> b errorOnComment c@(L s _) msg = exitMessageImpure $ let isMultiline = isCommentMultiline c in- showSrcSpan (RealSrcSpan (anchor s) Nothing) +++ showSrcSpan (RealSrcSpan (anchor s) GHC.Data.Strict.Nothing) ++ ": Error while reading hint file, " ++ msg ++ "\n" ++ (if isMultiline then "{-" else "--") ++ commentText c ++ (if isMultiline then "-}" else "")
src/Config/Yaml.hs view
@@ -22,7 +22,9 @@ #endif import GHC.Driver.Ppr-import GHC.Parser.Errors.Ppr+import GHC.Driver.Errors.Types+import GHC.Types.Error hiding (Severity)+ import Config.Type import Data.Either.Extra import Data.Maybe@@ -232,7 +234,7 @@ case parser defaultParseFlags{enabledExtensions=configExtensions, disabledExtensions=[]} x of POk _ x -> pure x PFailed ps ->- let errMsg = pprError . head . bagToList . snd $ getMessages ps+ let errMsg = head . bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages ps) msg = showSDoc baseDynFlags $ pprLocMsgEnvelope errMsg in parseFail v $ "Failed to parse " ++ msg ++ ", when parsing:\n " ++ x
src/GHC/All.hs view
@@ -25,11 +25,13 @@ import GHC.Hs import GHC.Types.SrcLoc import GHC.Types.Fixity+import GHC.Types.Error+import GHC.Driver.Errors.Types+ import GHC.Utils.Error import GHC.Parser.Lexer hiding (context) import GHC.LanguageExtensions.Type import GHC.Driver.Session hiding (extensions)-import GHC.Parser.Errors.Ppr import GHC.Data.Bag import Data.Generics.Uniplate.DataOnly @@ -181,14 +183,14 @@ -- Done with pragmas. Proceed to parsing. case fileToModule file str dynFlags of POk s a -> do- let errs = bagToList . snd $ getMessages s+ let errs = bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages s) if not $ null errs then ExceptT $ parseFailureErr dynFlags str file str errs else do let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags pure $ ModuleEx (applyFixities fixes a) PFailed s ->- ExceptT $ parseFailureErr dynFlags str file str $ bagToList . snd $ getMessages s+ ExceptT $ parseFailureErr dynFlags str file str $ bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages s) where -- If parsing pragmas fails, synthesize a parse error from the -- error message.@@ -197,7 +199,7 @@ in ParseError (mkSrcSpan loc loc) msg src parseFailureErr dynFlags ppstr file str errs =- let errMsg = pprError (head errs)+ let errMsg = head errs loc = errMsgSpan errMsg doc = pprLocMsgEnvelope errMsg in ghcFailOpParseModuleEx ppstr file str (loc, doc)
src/GHC/Util/ApiAnnotation.hs view
@@ -8,6 +8,7 @@ import GHC.LanguageExtensions.Type (Extension) import GHC.Parser.Annotation+import GHC.Hs.DocString import GHC.Types.SrcLoc import Language.Haskell.GhclibParserEx.GHC.Driver.Session@@ -33,14 +34,11 @@ -- | A comment as a string. comment_ :: LEpaComment -> String-comment_ (L _ (EpaComment (EpaBlockComment s ) _)) = s-comment_ (L _ (EpaComment (EpaLineComment s) _)) = s+comment_ (L _ (EpaComment (EpaDocComment ds ) _)) = renderHsDocString ds comment_ (L _ (EpaComment (EpaDocOptions s) _)) = s-comment_ (L _ (EpaComment (EpaDocCommentNamed s) _)) = s-comment_ (L _ (EpaComment (EpaDocCommentPrev s) _)) = s-comment_ (L _ (EpaComment (EpaDocCommentNext s) _)) = s-comment_ (L _ (EpaComment (EpaDocSection _ s) _)) = s-comment_ (L _ (EpaComment EpaEofComment _)) = ""+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
src/GHC/Util/Brackets.hs view
@@ -26,18 +26,18 @@ -- 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 e = noLocA $ HsPar EpAnnNotUsed e+ addParen = nlHsPar isAtom (L _ x) = case x of HsVar{} -> True HsUnboundVar{} -> True -- Technically atomic, but lots of people think it shouldn't be- HsRecFld{} -> False+ HsRecSel{} -> False HsOverLabel{} -> True HsIPVar{} -> True -- Note that sections aren't atoms (but parenthesized sections are).@@ -48,7 +48,8 @@ RecordCon{} -> True RecordUpd{} -> True ArithSeq{}-> True- HsBracket{} -> True+ HsTypedBracket{} -> True+ HsUntypedBracket{} -> True -- HsSplice might be $foo, where @($foo) would require brackets, -- but in that case the $foo is a type, so we can still mark Splice as atomic HsSpliceE{} -> True@@ -104,9 +105,9 @@ isAtomOrApp _ = False instance Brackets (LocatedA (Pat GhcPs)) where- remParen (L _ (ParPat _ x)) = Just x+ remParen (L _ (ParPat _ _ x _)) = Just x remParen _ = Nothing- addParen e = noLocA $ ParPat EpAnnNotUsed e+ addParen = nlParPat isAtom (L _ x) = case x of ParPat{} -> True
src/GHC/Util/FreeVars.hs view
@@ -99,9 +99,9 @@ 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 _ (HsLamCase _ _ 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 _ (HsLet _ _ binds _ e)) = inFree binds e -- Let (rec). freeVars (L _ (HsDo _ ctxt (L _ stmts))) = free (allVars stmts) -- Do block. freeVars (L _ (RecordCon _ _ (HsRecFields flds _))) = Set.unions $ map freeVars flds -- Record construction. freeVars (L _ (RecordUpd _ e flds)) =@@ -109,17 +109,15 @@ Left fs -> Set.unions $ freeVars e : map freeVars fs Right ps -> Set.unions $ freeVars e : map freeVars ps freeVars (L _ (HsMultiIf _ grhss)) = free (allVars grhss) -- Multi-way if.- freeVars (L _ (HsBracket _ (ExpBr _ e))) = freeVars e- freeVars (L _ (HsBracket _ (VarBr _ _ v))) = Set.fromList [occName (unLoc v)]+ freeVars (L _ (HsTypedBracket _ e)) = freeVars e+ freeVars (L _ (HsUntypedBracket _ (ExpBr _ e))) = freeVars e+ freeVars (L _ (HsUntypedBracket _ (VarBr _ _ v))) = Set.fromList [occName (unLoc v)] - freeVars (L _ HsConLikeOut{}) = mempty -- After typechecker.- freeVars (L _ HsRecFld{}) = mempty -- Variable pointing to a record selector.+ freeVars (L _ 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. freeVars (L _ HsLit{}) = mempty -- Simple literal.- freeVars (L _ HsRnBracketOut{}) = mempty -- Renamer produces these.- freeVars (L _ HsTcBracketOut{}) = mempty -- Typechecker produces these. -- freeVars (e@(L _ HsAppType{})) = freeVars $ children e -- Visible type application e.g. f @ Int x y. -- freeVars (e@(L _ HsApp{})) = freeVars $ children e -- Application.@@ -155,15 +153,15 @@ freeVars (Present _ args) = freeVars args freeVars _ = mempty -instance FreeVars (LocatedA (HsRecField GhcPs (LocatedA (HsExpr GhcPs)))) where- freeVars o@(L _ (HsRecField _ x _ True)) = Set.singleton $ occName $ unLoc $ rdrNameFieldOcc $ unLoc x -- a pun- freeVars o@(L _ (HsRecField _ _ x _)) = freeVars x+instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (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 (HsRecField' (AmbiguousFieldOcc GhcPs) (LocatedA (HsExpr GhcPs)))) where- freeVars (L _ (HsRecField _ _ x _)) = freeVars x+instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where+ freeVars (L _ (HsFieldBind _ _ x _)) = freeVars x -instance FreeVars (LocatedA (HsRecField' (FieldLabelStrings GhcPs) (LocatedA (HsExpr GhcPs)))) where- freeVars (L _ (HsRecField _ _ x _)) = freeVars x+instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) (LocatedA (HsExpr GhcPs)))) where+ freeVars (L _ (HsFieldBind _ _ x _)) = freeVars x instance AllVars (LocatedA (Pat GhcPs)) where allVars (L _ (VarPat _ (L _ x))) = Vars (Set.singleton $ rdrNameOcc x) Set.empty -- Variable pattern.@@ -188,8 +186,8 @@ allVars p = allVars $ children p -instance AllVars (LocatedA (HsRecField GhcPs (LocatedA (Pat GhcPs)))) where- allVars (L _ (HsRecField _ _ x _)) = allVars x+instance AllVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) (LocatedA (Pat GhcPs)))) where+ allVars (L _ (HsFieldBind _ _ x _)) = allVars x instance AllVars (LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))) where allVars (L _ (LastStmt _ expr _ _)) = freeVars_ expr -- The last stmt of a ListComp, MonadComp, DoExpr,MDoExpr.@@ -216,8 +214,6 @@ allVars (L _ PatBind{pat_lhs=n, pat_rhs=grhss}) = allVars n <> allVars grhss -- Ctor patterns and some other interesting cases e.g. Just x = e, (x) = e, x :: Ty = e. allVars (L _ (PatSynBind _ PSB{})) = mempty -- Come back to it.- allVars (L _ VarBind{}) = mempty -- Typechecker.- allVars (L _ AbsBinds{}) = mempty -- Not sure but I think renamer. instance AllVars (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where allVars (MG _ _alts@(L _ alts) _) = inVars (foldMap (allVars . m_pats) ms) (allVars (map m_grhss ms))@@ -237,7 +233,7 @@ instance AllVars (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where allVars (GRHSs _ grhss binds) = inVars binds (mconcatMap allVars grhss) -instance AllVars (Located (GRHS GhcPs (LocatedA (HsExpr GhcPs)))) where+instance AllVars (LocatedAn NoEpAnns (GRHS GhcPs (LocatedA (HsExpr GhcPs)))) where allVars (L _ (GRHS _ guards expr)) = Vars (bound gs) (free gs ^+ (freeVars expr ^- bound gs)) where gs = allVars guards instance AllVars (LocatedA (HsDecl GhcPs)) where
src/GHC/Util/HsExpr.hs view
@@ -58,7 +58,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 [noLoc $ GRHS EpAnnNotUsed [] body] (EmptyLocalBinds noExtField))]) Generated)+lambda vs body = noLocA $ HsLam noExtField (MG noExtField (noLocA [noLocA $ Match EpAnnNotUsed LambdaExpr vs (GRHSs emptyComments [noLocA $ GRHS EpAnnNotUsed [] body] (EmptyLocalBinds noExtField))]) Generated) -- | 'paren e' wraps 'e' in parens if 'e' is non-atomic. paren :: LHsExpr GhcPs -> LHsExpr GhcPs@@ -121,8 +121,8 @@ 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 (noLocA (HsPar EpAnnNotUsed y)))-simplifyExp e@(L _ (HsLet _ ((HsValBinds _ (ValBinds _ binds []))) z)) =+simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp EpAnnNotUsed 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 _))))]) _) _)]@@ -159,7 +159,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 +177,7 @@ , vars e `disjoint` [v] , L _ (HsVar _ (L _ fname)) <- f , isSymOcc $ rdrNameOcc fname- = let res = noLocA $ HsPar EpAnnNotUsed $ noLocA $ SectionL EpAnnNotUsed e f+ = let res = nlHsPar $ noLocA $ SectionL EpAnnNotUsed e f in (res, \s -> [Replace Expr s [] (unsafePrettyPrint res)]) -- @\vs v -> f x v@ ==> @\vs -> f x@@@ -213,7 +213,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 =@@ -239,7 +239,7 @@ niceLambdaR [] e = (e, \s -> [Replace Expr s [("a", toSSA e)] "a"]) -- Base case. Just a good old fashioned lambda. niceLambdaR ss e =- let grhs = noLoc $ GRHS EpAnnNotUsed [] e :: LGRHS GhcPs (LHsExpr GhcPs)+ let grhs = noLocA $ GRHS EpAnnNotUsed [] 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]}@@ -298,7 +298,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
@@ -14,6 +14,7 @@ import GHC.Data.FastString import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence+import GHC.Types.PkgQual import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable@@ -34,7 +35,10 @@ where -- Package qualifier of an import declaration. pkg :: LImportDecl GhcPs -> Maybe StringLiteral- pkg (L _ x) = ideclPkgQual x+ pkg (L _ x) =+ case ideclPkgQual x of+ RawPkgQual s -> Just s+ NoRawPkgQual -> Nothing -- The import declaraions contained by the module 'xs'. res :: [LImportDecl GhcPs]
src/GHC/Util/SrcLoc.hs view
@@ -10,6 +10,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Data.FastString+import qualified GHC.Data.Strict import Data.Default import Data.Data@@ -18,7 +19,7 @@ -- 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)) Nothing+getAncLoc o = RealSrcSpan (anchor (getLoc o)) GHC.Data.Strict.Nothing -- 'stripLocs x' is 'x' with all contained source locs replaced by -- 'noSrcSpan'.@@ -36,6 +37,12 @@ newtype SrcSpanD = SrcSpanD SrcSpan deriving (Outputable, Eq) instance Default SrcSpanD where def = SrcSpanD noSrcSpan++newtype FastStringD = FastStringD FastString+ deriving Eq+compareFastStrings (FastStringD f) (FastStringD g) =+ lexicalCompareFS f g+instance Ord FastStringD where compare = compareFastStrings -- SrcSpan no longer provides 'Ord' so we are forced to roll our own. --
src/GHC/Util/Unify.hs view
@@ -128,7 +128,6 @@ | 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 AnnsLet) <- 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@@ -138,6 +137,8 @@ | Just (x :: EpAnn HsRuleAnn) <- 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 :: TokenLocation) <- cast y = Just mempty | Just (y :: SrcSpan) <- cast y = Just mempty | otherwise = unifyDef' nm x y@@ -257,8 +258,8 @@ unifyExp' nm root x y@(L _ (OpApp _ lhs2 op2@(L _ (HsVar _ op2')) rhs2)) = noExtra $ unifyExp nm root x y -unifyExp' nm root (L _ (HsBracket _ (VarBr _ b0 (occNameStr . unLoc -> v1))))- (L _ (HsBracket _ (VarBr _ b1 (occNameStr . unLoc -> v2))))+unifyExp' nm root (L _ (HsUntypedBracket _ (VarBr _ b0 (occNameStr . unLoc -> v1))))+ (L _ (HsUntypedBracket _ (VarBr _ b1 (occNameStr . unLoc -> v2)))) | b0 == b1 && isUnifyVar v1 = Just (Subst [(v1, strToVar v2)]) unifyExp' nm root x y | isOther x, isOther y = unifyDef' nm x y
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
src/Hint/Bracket.hs view
@@ -134,13 +134,13 @@ -- 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 @@ -151,8 +151,8 @@ -- latter (in contrast to the HSE pretty printer). This patches things -- up. prettyExpr :: LHsExpr GhcPs -> String-prettyExpr s@(L _ SectionL{}) = unsafePrettyPrint (noLocA (HsPar EpAnnNotUsed s) :: LHsExpr GhcPs)-prettyExpr s@(L _ SectionR{}) = unsafePrettyPrint (noLocA (HsPar EpAnnNotUsed s) :: LHsExpr GhcPs)+prettyExpr s@(L _ SectionL{}) = unsafePrettyPrint (nlHsPar s :: LHsExpr GhcPs)+prettyExpr s@(L _ SectionR{}) = unsafePrettyPrint (nlHsPar s :: LHsExpr GhcPs) prettyExpr x = unsafePrettyPrint x -- 'Just _' if at least one set of parens were removed. 'Nothing' if@@ -227,10 +227,9 @@ where -- If we call 'unsafePrettyPrint' on a field decl, we won't like -- the output (e.g. "[foo, bar] :: T"). Here we use a custom- -- printer to work around (snarfed from- -- https://hackage.haskell.org/package/ghc-lib-parser-8.8.1/docs/src/HsTypes.html#pprConDeclFields).+ -- printer to work around (snarfed from Hs.Types.pprConDeclFields) ppr_fld (L _ ConDeclField { cd_fld_names = ns, cd_fld_type = ty, cd_fld_doc = doc })- = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc+ = pprMaybeWithDoc doc (ppr_names ns <+> dcolon <+> ppr ty) ppr_fld (L _ (XConDeclField x)) = ppr x ppr_names [n] = ppr n@@ -250,20 +249,20 @@ , 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 (noLocA (HsPar EpAnnNotUsed a2))+ , let y = noLocA $ HsApp EpAnnNotUsed 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 == "<$>"+ | 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 , 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 r = Replace Expr (toSSA x) [("x", toSSA a), ("op", toSSA b), ("y", toSSA c)] "x op y"]
src/Hint/Comment.hs view
@@ -21,6 +21,7 @@ import GHC.Types.SrcLoc import GHC.Parser.Annotation import GHC.Util+import qualified GHC.Data.Strict directives :: [String] directives = words $@@ -44,7 +45,7 @@ grab :: String -> LEpaComment -> String -> Idea grab msg o@(L pos _) s2 = let s1 = commentText o- loc = RealSrcSpan (anchor pos) Nothing+ loc = RealSrcSpan (anchor 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/Extensions.hs view
@@ -244,6 +244,10 @@ f = (.foo) {-# LANGUAGE OverloadedRecordDot #-} \ f = (. foo) -- @NoRefactor: refactor requires GHC >= 9.2.1+{-# LANGUAGE TemplateHaskellQuotes #-} \+foo = [|| x ||]+{-# LANGUAGE TemplateHaskell #-} \+foo = $bar </TEST> -} @@ -268,6 +272,8 @@ import GHC.Types.Basic import GHC.Types.Name.Reader import GHC.Types.ForeignCall+import qualified GHC.Data.Strict+import GHC.Types.PkgQual import GHC.Util import GHC.LanguageExtensions.Type@@ -286,7 +292,7 @@ extensionsHint _ x = [ rawIdea Hint.Type.Warning "Unused LANGUAGE pragma"- (RealSrcSpan (anchor sl) Nothing)+ (RealSrcSpan (anchor sl) GHC.Data.Strict.Nothing) (comment_ (mkLanguagePragmas sl exts)) (Just newPragma) ( [RequiresExtension (show gone) | (_, Just x) <- before \\ after, gone <- Map.findWithDefault [] x disappear] ++@@ -372,21 +378,9 @@ usedExt DeriveAnyClass = not . null . derivesAnyclass . derives usedExt x = used x --- The ghc-lib-parser-ex functions are getting fixed to have the new--- signatures.-isMDo' :: HsStmtContext GhcRn -> Bool-isMDo' = \case MDoExpr _ -> True; _ -> False-isStrictMatch' :: HsMatchContext GhcPs -> Bool-isStrictMatch' = \case FunRhs{mc_strictness=SrcStrict} -> True; _ -> False--isGetField :: LHsExpr GhcPs -> Bool-isGetField = \case (L _ HsGetField{}) -> True; _ -> False-isProjection :: LHsExpr GhcPs -> Bool-isProjection = \case (L _ HsProjection{}) -> True; _ -> False- used :: Extension -> Located HsModule -> Bool -used RecursiveDo = hasS isMDo' ||^ hasS isRecStmt+used RecursiveDo = hasS isMDo ||^ hasS isRecStmt used ParallelListComp = hasS isParComp used FunctionalDependencies = hasT (un :: FunDep GhcPs) used ImplicitParams = hasT (un :: HsIPName)@@ -400,12 +394,17 @@ where f :: HsExpr GhcPs -> Bool f (HsCase _ _ (MG _ (L _ []) _)) = True- f (HsLamCase _ (MG _ (L _ []) _)) = True+ f (HsLamCase _ _ (MG _ (L _ []) _)) = True f _ = False used KindSignatures = hasT (un :: HsKind GhcPs)-used BangPatterns = hasS isPBangPat ||^ hasS isStrictMatch'-used TemplateHaskell = hasS $ \case (HsQuasiQuote{} :: HsSplice GhcPs) -> False; _ -> True-used TemplateHaskellQuotes = hasT (un :: HsBracket GhcPs)+used BangPatterns = hasS isPBangPat ||^ hasS isStrictMatch+used TemplateHaskell = hasS $ not . isQuasiQuoteSplice+used TemplateHaskellQuotes = hasS f+ where+ f :: HsExpr GhcPs -> Bool+ f HsTypedBracket{} = True+ f HsUntypedBracket{} = True+ f _ = False used ForeignFunctionInterface = hasT (un :: CCallConv) used PatternGuards = hasS f where@@ -433,7 +432,7 @@ isOp (L _ name) = isSymbolRdrName name used RecordWildCards = hasS hasFieldsDotDot ||^ hasS hasPFieldsDotDot-used RecordPuns = hasS isPFieldPun ||^ hasS isFieldPun ||^ hasS isFieldPunUpdate+used NamedFieldPuns = hasS isPFieldPun ||^ hasS isFieldPun ||^ hasS isFieldPunUpdate used UnboxedTuples = hasS isUnboxedTuple ||^ hasS (== Unboxed) ||^ hasS isDeriving where -- detect if there are deriving declarations or data ... deriving stuff@@ -444,9 +443,9 @@ used PackageImports = hasS f where f :: ImportDecl GhcPs -> Bool- f ImportDecl{ideclPkgQual=Just _} = True+ f ImportDecl{ideclPkgQual=RawPkgQual _} = True f _ = False-used QuasiQuotes = hasS isQuasiQuote ||^ hasS isTyQuasiQuote+used QuasiQuotes = hasS isQuasiQuoteExpr ||^ hasS isTyQuasiQuote used ViewPatterns = hasS isPViewPat used InstanceSigs = hasS f where@@ -483,11 +482,7 @@ isListPat ListPat{} = True isListPat _ = False -used OverloadedLabels = hasS isLabel- where- isLabel :: HsExpr GhcPs -> Bool- isLabel HsOverLabel{} = True- isLabel _ = False+used OverloadedLabels = hasS isOverLabel used Arrows = hasS isProc used TransformListComp = hasS isTransStmt@@ -498,7 +493,7 @@ used PatternSynonyms = hasS isPatSynBind ||^ hasS isPatSynIE used ImportQualifiedPost = hasS (== QualifiedPost) used StandaloneKindSignatures = hasT (un :: StandaloneKindSig GhcPs)-used OverloadedRecordDot = hasS isGetField ||^ hasS isProjection+used OverloadedRecordDot = hasT (un :: DotFieldOcc GhcPs) used _= const True @@ -543,9 +538,11 @@ decl _ = mempty g :: NewOrData -> [LHsDerivingClause GhcPs] -> Derives- g dn ds = mconcat- ([addDerives (Just dn) (fmap unLoc strategy) $ map derivedToStr tys | L _ (HsDerivingClause _ strategy (L _ (DctMulti _ tys))) <- ds] ++- [addDerives (Just dn) (fmap unLoc strategy) $ map derivedToStr [ty] | L _ (HsDerivingClause _ strategy (L _ (DctSingle _ ty))) <- ds])+ g dn ds = mconcat [addDerives (Just dn) (fmap unLoc strategy) $ map derivedToStr tys | (strategy, tys) <- stys]+ where+ stys =+ [(strategy, [ty]) | L _ (HsDerivingClause _ strategy (L _ (DctSingle _ ty))) <- ds] +++ [(strategy, tys ) | L _ (HsDerivingClause _ strategy (L _ (DctMulti _ tys))) <- ds] derivedToStr :: LHsSigType GhcPs -> String derivedToStr (L _ (HsSig _ _ t)) = ih t
src/Hint/Import.hs view
@@ -52,9 +52,16 @@ import GHC.Hs import GHC.Types.SrcLoc import GHC.Unit.Types -- for 'NotBoot'+import GHC.Types.PkgQual import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable +rawPkgQualToMaybe :: RawPkgQual -> Maybe StringLiteral+rawPkgQualToMaybe x =+ case x of+ NoRawPkgQual -> Nothing+ RawPkgQual lit -> Just lit+ importHint :: ModuHint importHint _ ModuleEx {ghcModule=L _ HsModule{hsmodImports=ms}} = -- Ideas for combining multiple imports.@@ -63,7 +70,7 @@ , ideclSource (unLoc i) == NotBoot , let i' = unLoc i , let n = unLoc $ ideclName i'- , let pkg = unpackFS . sl_fs <$> ideclPkgQual i']) +++ , let pkg = unpackFS . sl_fs <$> rawPkgQualToMaybe (ideclPkgQual i')]) ++ -- Ideas for removing redundant 'as' clauses. concatMap stripRedundantAlias ms
src/Hint/Lambda.hs view
@@ -120,7 +120,7 @@ import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader import GHC.Types.SrcLoc-import Language.Haskell.GhclibParserEx.GHC.Hs.Expr (isTypeApp, isOpApp, isLambda, isQuasiQuote, isVar, isDol, strToVar)+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr (isTypeApp, isOpApp, isLambda, isQuasiQuoteExpr, isVar, isDol, strToVar) import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import GHC.Util.Brackets (isAtom)@@ -169,7 +169,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 [noLoc $ GRHS EpAnnNotUsed [] b] $ EmptyLocalBinds noExtField]) Generated}+ origBind {fun_matches = MG noExtField (noLocA [noLocA $ Match EpAnnNotUsed ctxt ps $ GRHSs emptyComments [noLocA $ GRHS EpAnnNotUsed [] b] $ EmptyLocalBinds noExtField]) Generated} mkSubtsAndTpl newPats newBody = (sub, tpl) where@@ -183,13 +183,13 @@ etaReduce (unsnoc -> Just (ps, view -> PVar_ p)) (L _ (HsApp _ x (view -> Var_ y))) | p == y , y `notElem` vars x- , not $ any isQuasiQuote $ universe x+ , not $ any isQuasiQuoteExpr $ universe x = etaReduce ps x etaReduce ps (L loc (OpApp _ x (isDol -> True) y)) = etaReduce ps (L loc (HsApp EpAnnNotUsed 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,15 +197,15 @@ = [suggest "Use section" (reLoc o) (reLoc to) [r]] where to :: LHsExpr GhcPs- to = noLocA $ HsPar EpAnnNotUsed $ noLocA $ SectionL EpAnnNotUsed y oper+ to = nlHsPar $ noLocA $ SectionL EpAnnNotUsed 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 = noLocA $ HsPar EpAnnNotUsed $ noLocA $ SectionR EpAnnNotUsed origf y+ to = nlHsPar $ noLocA $ SectionR EpAnnNotUsed origf y op = if isSymbolRdrName (unLoc f) then unsafePrettyPrint f else "`" ++ unsafePrettyPrint f ++ "`"@@ -216,13 +216,13 @@ | not $ any isOpApp p , (res, refact) <- niceLambdaR [] o , not $ isLambda res- , not $ any isQuasiQuote $ universe res+ , not $ any isQuasiQuoteExpr $ universe res , not $ "runST" `Set.member` Set.map occNameString (freeVars o) , let name = "Avoid lambda" ++ (if countRightSections res > countRightSections o then " using `infix`" else "") -- If the lambda's parent is an HsPar, and the result is also an HsPar, the span should include the parentheses. , 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@@ -294,7 +294,7 @@ -- otherwise we should use @LambdaCase@ MG _ (L _ _) _ ->- [(suggestN "Use lambda-case" (reLoc o) $ noLoc $ HsLamCase EpAnnNotUsed matchGroup)+ [(suggestN "Use lambda-case" (reLoc o) $ noLoc $ HsLamCase EpAnnNotUsed LamCase matchGroup) {ideaNote=[RequiresExtension "LambdaCase"]}] _ -> [] where
src/Hint/List.hs view
@@ -54,7 +54,7 @@ import GHC.Hs import GHC.Types.SrcLoc-import GHC.Types.Basic+import GHC.Types.Basic hiding (Pattern) import GHC.Types.SourceText import GHC.Types.Name.Reader import GHC.Data.FastString@@ -97,7 +97,7 @@ listCompCheckMap o mp f MonadComp stmts listComp _ = [] -listCompCheckGuards :: LHsExpr GhcPs -> HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> [Idea]+listCompCheckGuards :: LHsExpr GhcPs -> HsDoFlavour -> [ExprLStmt GhcPs] -> [Idea] listCompCheckGuards o ctx stmts = let revs = reverse stmts e@(L _ LastStmt{}) = head revs -- In a ListComp, this is always last.@@ -120,7 +120,7 @@ qualCon _ = Nothing listCompCheckMap ::- LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> [Idea]+ LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsDoFlavour -> [ExprLStmt GhcPs] -> [Idea] listCompCheckMap o mp f ctx stmts | varToStr mp == "map" = [suggest "Move map inside list comprehension" (reLoc o) (reLoc o2) (suggestExpr o o2)] where
src/Hint/ListRec.hs view
@@ -173,7 +173,7 @@ 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 = noLoc $ GRHS EpAnnNotUsed [] e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs.+ gRHS e = noLocA $ GRHS EpAnnNotUsed [] 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.@@ -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
@@ -156,7 +156,7 @@ -- we have lambdas we might be moving, and QuasiQuotes, we might -- inadvertantly break free vars because quasi quotes don't show -- what free vars they make use of.- guard $ not (any isLambda $ universe lhs) || not (any isQuasiQuote $ universe x)+ guard $ not (any isLambda $ universe lhs) || not (any isQuasiQuoteExpr $ universe x) guard $ checkSide (unextendInstances <$> hintRuleSide) $ ("original", x) : ("result", res) : fromSubst u guard $ checkDefine declName parent rhs@@ -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@@ -206,7 +206,7 @@ isType "Neg" (asInt -> Just x) | x < 0 = True isType "NegZero" (asInt -> Just x) | x <= 0 = True isType "LitInt" (L _ (HsLit _ HsInt{})) = True- isType "LitInt" (L _ (HsOverLit _ (OverLit _ HsIntegral{} _))) = True+ isType "LitInt" (L _ (HsOverLit _ (OverLit _ HsIntegral{}))) = True isType "LitString" (L _ (HsLit _ HsString{})) = True isType "Var" (L _ HsVar{}) = True isType "App" (L _ HsApp{}) = True@@ -219,10 +219,10 @@ 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+ asInt (L _ (HsOverLit _ (OverLit _ (HsIntegral (IL _ _ x))))) = Just x asInt _ = Nothing list :: LHsExpr GhcPs -> [LHsExpr GhcPs]@@ -264,7 +264,7 @@ f x = scopeMove (from, x) to addBracket :: Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs-addBracket (Just (i, p)) c | needBracketOld i p c = noLocA $ HsPar EpAnnNotUsed c+addBracket (Just (i, p)) c | needBracketOld i p c = nlHsPar c addBracket _ x = x -- Type substitution e.g. 'Foo Int' for 'a' in 'Proxy a' can lead to a
src/Hint/Monad.hs view
@@ -77,6 +77,8 @@ import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence import GHC.Data.Bag+import qualified GHC.Data.Strict+ import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable@@ -133,7 +135,7 @@ _ -> [] where f = monadNoResult (fromMaybe "" decl) id- seenVoid wrap (L l (HsPar x y)) = seenVoid (wrap . L l . HsPar x) y+ seenVoid wrap (L l (HsPar x p y q)) = seenVoid (wrap . L l . \y -> HsPar x p y q) 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]@@ -159,7 +161,7 @@ RealSrcSpan s _ -> let start = realSrcSpanStart s end = mkRealSrcLoc (srcSpanFile s) (srcLocLine start) (srcLocCol start + length doOrMDo)- in RealSrcSpan (mkRealSrcSpan start end) Nothing+ in RealSrcSpan (mkRealSrcSpan start end) GHC.Data.Strict.Nothing -- Sometimes people write 'a * do a + b', to avoid brackets, -- or using BlockArguments they can write 'a do a b',@@ -187,7 +189,7 @@ modifyAppHead f = go id where go :: (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> (LHsExpr GhcPs, Maybe a)- go wrap (L l (HsPar _ x)) = go (wrap . L l . HsPar EpAnnNotUsed) x+ go wrap (L l (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 (HsVar _ x)) = (wrap (L l (HsVar NoExtField x')), Just a)@@ -202,7 +204,7 @@ -- See through HsPar, and down HsIf/HsCase, return the name to use in -- the hint, and the revised expression. monadNoResult :: String -> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]-monadNoResult inside wrap (L l (HsPar _ x)) = monadNoResult inside (wrap . L l . HsPar EpAnnNotUsed) 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 EpAnnNotUsed 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@@ -292,7 +294,7 @@ template :: String -> LHsExpr GhcPs -> ExprLStmt GhcPs template lhs rhs = let p = noLocA $ mkRdrUnqual (mkVarOcc lhs)- grhs = noLoc (GRHS EpAnnNotUsed [] rhs)+ grhs = noLocA (GRHS EpAnnNotUsed [] 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) []@@ -307,7 +309,7 @@ fromApplies x = ([], x) fromRet :: LHsExpr GhcPs -> Maybe (String, LHsExpr GhcPs)-fromRet (L _ (HsPar _ x)) = fromRet x+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 _ (HsApp _ x y)) | isReturn x = Just (unsafePrettyPrint x, y) fromRet _ = Nothing
src/Hint/NewType.hs view
@@ -17,7 +17,7 @@ data Pair a b = Pair a b data Foo = Bar data Foo a = Eq a => MkFoo a-data Foo a = () => Foo a -- newtype Foo a = Foo a+data Foo a = () => Foo a -- newtype Foo a = () => Foo a data X = Y {-# UNPACK #-} !Int -- newtype X = Y Int data A = A {b :: !C} -- newtype A = A {b :: C} data A = A Int#
src/Hint/NumLiteral.hs view
@@ -40,13 +40,13 @@ const [] suggestUnderscore :: LHsExpr GhcPs -> [Idea]-suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsIntegral intLit@(IL (SourceText srcTxt) _ _)) _))) =+suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsIntegral intLit@(IL (SourceText srcTxt) _ _))))) = [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` srcTxt, srcTxt /= underscoredSrcTxt ] where underscoredSrcTxt = addUnderscore srcTxt y = noLocA $ HsOverLit EpAnnNotUsed $ ol{ol_val = HsIntegral intLit{il_text = SourceText underscoredSrcTxt}} r = Replace Expr (toSSA x) [("a", toSSA y)] "a"-suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsFractional fracLit@(FL (SourceText srcTxt) _ _ _ _)) _))) =+suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsFractional fracLit@(FL (SourceText srcTxt) _ _ _ _))))) = [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` srcTxt, srcTxt /= underscoredSrcTxt ] where underscoredSrcTxt = addUnderscore srcTxt
src/Hint/Pattern.hs view
@@ -73,7 +73,8 @@ import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence import GHC.Data.Bag-import GHC.Types.Basic+import GHC.Types.Basic hiding (Pattern)+import qualified GHC.Data.Strict import GHC.Util import Language.Haskell.GhclibParserEx.GHC.Hs.Pat@@ -120,7 +121,7 @@ mkGuard a = GRHS EpAnnNotUsed [noLocA $ BodyStmt noExtField a noSyntaxExpr noSyntaxExpr] guards :: [LGRHS GhcPs (LHsExpr GhcPs)]- guards = map (noLoc . uncurry mkGuard) rawGuards+ guards = map (noLocA . uncurry mkGuard) rawGuards (lhs, rhs) = unzip rawGuards @@ -137,7 +138,7 @@ ps -> mkTemplate "p100" ps guardSubts = mkTemplate "g100" lhs exprSubts = mkTemplate "e100" rhs- templateGuards = map noLoc (zipWith (mkGuard `on` toString) guardSubts exprSubts)+ templateGuards = map noLocA (zipWith (mkGuard `on` toString) guardSubts exprSubts) toString (Left e) = e toString (Right (v, _)) = strToVar v@@ -151,7 +152,7 @@ refactoring = Replace rtype (toRefactSrcSpan l) (f patSubts ++ f guardSubts ++ f exprSubts) template hints gen (Pattern l t pats o@(GRHSs _ [L _ (GRHS _ [test] bod)] bind)) | unsafePrettyPrint test `elem` ["otherwise", "True"]- = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLoc (GRHS EpAnnNotUsed [] bod)]}) [Delete Stmt (toSSA test)]]+ = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLocA (GRHS EpAnnNotUsed [] 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@@ -164,15 +165,15 @@ RealSrcSpan s _ -> let end = realSrcSpanEnd s start = mkRealSrcLoc (srcSpanFile s) (srcLocLine end) (srcLocCol end - 5)- in RealSrcSpan (mkRealSrcSpan start end) Nothing+ in RealSrcSpan (mkRealSrcSpan start end) GHC.Data.Strict.Nothing hints gen (Pattern l t pats o@(GRHSs _ (unsnoc -> Just (gs, L _ (GRHS _ [test] bod))) binds)) | unsafePrettyPrint test == "True" = let otherwise_ = noLocA $ BodyStmt noExtField (strToVar "otherwise") noSyntaxExpr noSyntaxExpr in- [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLoc (GRHS EpAnnNotUsed [otherwise_] bod)]}) [Replace Expr (toSSA test) [] "otherwise"]]+ [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLocA (GRHS EpAnnNotUsed [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)] @@ -206,7 +207,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@@ -220,7 +221,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
src/Hint/Pragma.hs view
@@ -25,7 +25,7 @@ {-# LANGUAGE RebindableSyntax #-} \ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RebindableSyntax #-} \-{-# LANGUAGE EmptyCase, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase #-}+{-# LANGUAGE EmptyCase, RebindableSyntax #-} -- {-# LANGUAGE EmptyCase, RebindableSyntax #-} </TEST> -}
src/Hint/Unsafe.hs view
@@ -63,10 +63,10 @@ gen :: OccName -> LHsDecl GhcPs gen x = noLocA $ SigD noExtField (InlineSig EpAnnNotUsed (noLocA (mkRdrUnqual x))- (InlinePragma (SourceText "{-# NOINLINE") NoInline Nothing NeverActive FunLike))+ (InlinePragma (SourceText "{-# NOINLINE") (NoInline (SourceText "{-# NOINLINE")) Nothing NeverActive FunLike)) noinline :: [OccName] noinline = [q | L _(SigD _ (InlineSig _ (L _ (Unqual q))- (InlinePragma _ NoInline Nothing NeverActive FunLike))+ (InlinePragma _ (NoInline (SourceText "{-# NOINLINE")) Nothing NeverActive FunLike)) ) <- hsmodDecls m] isUnsafeDecl :: HsDecl GhcPs -> Bool
tests/cpp.test view
@@ -44,8 +44,7 @@ main = undefined EXIT 1 OUTPUT-tests/cpp-ext-enable.hs:1:1: Error: Parse error: Unsupported extension: Foo-+tests/cpp-ext-enable.hs:1:1: Error: Parse error: tests/cpp-ext-enable.hs:3:14: error: Unsupported extension: Foo Found: {-# LANGUAGE CPP #-}
tests/parse-error.test view
@@ -25,8 +25,8 @@ FILE tests/ignore-parse-error3.hs {-# LANGUAGE InvalidExtension #-} OUTPUT-tests/ignore-parse-error3.hs:1:1: Error: Parse error: Unsupported extension: InvalidExtension-+tests/ignore-parse-error3.hs:1:1: Error: Parse error: tests/ignore-parse-error3.hs:1:14: error:+ Unsupported extension: InvalidExtension Found: {-# LANGUAGE InvalidExtension #-}
tests/serialise.test view
@@ -37,7 +37,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-} OUTPUT-[("tests/serialise-four.hs:1:1-20: Warning: Use fewer LANGUAGE pragmas\nFound:\n {-# LANGUAGE CPP #-}\n {-# LANGUAGE CPP #-}\nPerhaps:\n {-# LANGUAGE CPP #-}\n",[ModifyComment {pos = SrcSpan {startLine = 1, startCol = 1, endLine = 1, endCol = 21}, newComment = "{-# LANGUAGE CPP #-}"},ModifyComment {pos = SrcSpan {startLine = 2, startCol = 1, endLine = 2, endCol = 21}, newComment = ""}])]+[("tests/serialise-four.hs:2:1-20: Warning: Use fewer LANGUAGE pragmas\nFound:\n {-# LANGUAGE CPP #-}\n {-# LANGUAGE CPP #-}\nPerhaps:\n {-# LANGUAGE CPP #-}\n",[ModifyComment {pos = SrcSpan {startLine = 2, startCol = 1, endLine = 2, endCol = 21}, newComment = "{-# LANGUAGE CPP #-}"},ModifyComment {pos = SrcSpan {startLine = 1, startCol = 1, endLine = 1, endCol = 21}, newComment = ""}])]+ ---------------------------------------------------------------------