hlint 3.3.6 → 3.4
raw patch · 57 files changed
+1924/−719 lines, 57 filesdep ~ghcdep ~ghc-lib-parserdep ~ghc-lib-parser-exPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghc, ghc-lib-parser, ghc-lib-parser-ex
API changes (from Hackage documentation)
- Language.Haskell.HLint: NoCpp :: CppFlags
+ Language.Haskell.HLint: createModuleExWithFixities :: [(String, Fixity)] -> Located HsModule -> ModuleEx
- Language.Haskell.HLint: createModuleEx :: ApiAnns -> Located HsModule -> ModuleEx
+ Language.Haskell.HLint: createModuleEx :: Located HsModule -> ModuleEx
Files
- CHANGES.txt +21/−0
- LICENSE +1/−1
- README.md +45/−6
- data/hintrule-implies-classify.yaml +2/−0
- data/hlint.yaml +51/−6
- data/import_style.yaml +6/−0
- data/wildcard-import.yaml +0/−1
- data/wildcard.yaml +0/−1
- data/wildcards.yaml +31/−0
- hlint.cabal +10/−6
- src/Apply.hs +8/−2
- src/CmdLine.hs +5/−6
- src/Config/Compute.hs +7/−7
- src/Config/Haskell.hs +7/−6
- src/Config/Type.hs +19/−0
- src/Config/Yaml.hs +81/−27
- src/Extension.hs +3/−0
- src/Fixity.hs +5/−3
- src/GHC/All.hs +32/−44
- src/GHC/Util/ApiAnnotation.hs +31/−40
- src/GHC/Util/Brackets.hs +9/−9
- src/GHC/Util/FreeVars.hs +40/−34
- src/GHC/Util/HsExpr.hs +24/−23
- src/GHC/Util/Scope.hs +48/−31
- src/GHC/Util/SrcLoc.hs +16/−4
- src/GHC/Util/Unify.hs +43/−15
- src/GHC/Util/View.hs +16/−16
- src/Hint/All.hs +0/−1
- src/Hint/Bracket.hs +28/−32
- src/Hint/Comment.hs +7/−5
- src/Hint/Duplicate.hs +3/−3
- src/Hint/Export.hs +3/−3
- src/Hint/Extensions.hs +42/−21
- src/Hint/Fixities.hs +4/−4
- src/Hint/Import.hs +12/−13
- src/Hint/Lambda.hs +37/−37
- src/Hint/List.hs +38/−37
- src/Hint/ListRec.hs +17/−15
- src/Hint/Match.hs +17/−20
- src/Hint/Monad.hs +36/−35
- src/Hint/Naming.hs +4/−3
- src/Hint/NewType.hs +11/−11
- src/Hint/NumLiteral.hs +10/−10
- src/Hint/Pattern.hs +30/−30
- src/Hint/Pragma.hs +30/−25
- src/Hint/Restrict.hs +84/−30
- src/Hint/Smell.hs +11/−14
- src/Hint/Unsafe.hs +7/−6
- src/Language/Haskell/HLint.hs +5/−2
- src/Refact.hs +10/−1
- src/Test/Annotations.hs +4/−1
- tests/hintrule-implies-classify.test +12/−0
- tests/import_style.test +68/−0
- tests/no_explicit_cpp.test +17/−0
- tests/wildcard-import.test +0/−27
- tests/wildcard.test +0/−45
- tests/wildcards.test +816/−0
CHANGES.txt view
@@ -1,5 +1,23 @@ Changelog for HLint (* = breaking change) +3.4, released 2022-04-24+ #1360, make -XHaskell2010 still obey CPP pragmas+ #1368, make TH quotation bracket rule off by default+ #1367, add brackets on refactoring templates when needed+ #1348, make module restrict hints more powerful+ #1363, add more hints for <$>+ #1362, add support for language specifier GHC2021+ #1342, make module wildcards work with `within` restrictions+ #1340, include Restriction hints in splitSettings and argsSettings output+ #1330, make ignore: {} not ignore subsequent hints+ #1317, evaluating all/any/allM/anyM on simple lists+ #1303, allow more matches for modules doing `import Prelude ()`+ #1324, add createModuleExWithFixities+ #1336, warn on unused OverloadedRecordDot+ #1334, don't remove TypeApplications if there are type-level type applications+ #1332, suggest using iterate instead of scanl/foldl+ #1331, suggest using min/max instead of if+* #1247, move to GHC 9.2 3.3.6, released 2021-12-29 #1326, produce release binaries 3.3.5, released 2021-12-12@@ -47,6 +65,9 @@ Drop GHC 8.6 support #1206, require apply-refact 0.9.0.0 or higher #1205, generalize hints which were with '&' form+3.2.8, released 2021-12-27+ #1304, support aeson-2.0+ #1286, compatibility with extra-1.7.10 3.2.7, released 2021-01-16 #1202, add missing parentheses for Avoid Lambda #1201, allow matching through the & operator (similar to $)
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2006-2021.+Copyright Neil Mitchell 2006-2022. All rights reserved. Redistribution and use in source and binary forms, with or without
README.md view
@@ -282,11 +282,11 @@ * `{-# ANN module "HLint: ignore" #-}` or `{-# HLINT ignore #-}` or `{- HLINT ignore -}` - ignore all hints in this module (use `module` literally, not the name of the module). * `{-# ANN module "HLint: ignore Eta reduce" #-}` or `{-# HLINT ignore "Eta reduce" #-}` or `{- HLINT ignore "Eta reduce" -}` - ignore all eta reduction suggestions in this module.-* `{-# ANN myFunction "HLint: ignore" #-}` or `{-# HLINT ignore myFunction #-}` or `{- HLINT ignore myFunction -}` - don't give any hints in the function `myFunction`. This may be combined with hint names, `{- HLINT ignore myFunction "Eta reduce" -}`, to only ignore that hint in that function.-* `{-# ANN myFunction "HLint: error" #-}` or `{-# HLINT error myFunction #-}` or `{- HLINT error myFunction -}` - any hint in the function `myFunction` is an error.+* `{-# ANN myDef "HLint: ignore" #-}` or `{-# HLINT ignore myDef #-}` or `{- HLINT ignore myDef -}` - don't give any hints in the definition `myDef`. This may be combined with hint names, `{- HLINT ignore myDef "Eta reduce" -}`, to only ignore that hint in that definition.+* `{-# ANN myDef "HLint: error" #-}` or `{-# HLINT error myDef #-}` or `{- HLINT error myDef -}` - any hint in the definition `myDef` is an error. * `{-# ANN module "HLint: error Use concatMap" #-}` or `{-# HLINT error "Use concatMap" #-}` or `{- HLINT error "Use concatMap" -}` - the hint to use `concatMap` is an error (you may also use `warn` or `suggest` in place of `error` for other severity levels). -For `ANN` pragmas it is important to put them _after_ any `import` statements. If you have the `OverloadedStrings` extension enabled you will need to give an explicit type to the annotation, e.g. `{-# ANN myFunction ("HLint: ignore" :: String) #-}`. The `ANN` pragmas can also increase compile times or cause more recompilation than otherwise required, since they are evaluated by `TemplateHaskell`.+For `ANN` pragmas it is important to put them _after_ any `import` statements. If you have the `OverloadedStrings` extension enabled you will need to give an explicit type to the annotation, e.g. `{-# ANN myDef ("HLint: ignore" :: String) #-}`. The `ANN` pragmas can also increase compile times or cause more recompilation than otherwise required, since they are evaluated by `TemplateHaskell`. For `{-# HLINT #-}` pragmas GHC may give a warning about an unrecognised pragma, which can be suppressed with `-Wno-unrecognised-pragmas`. @@ -296,8 +296,8 @@ * `- ignore: {name: Eta reduce}` - suppress all eta reduction suggestions. * `- ignore: {name: Eta reduce, within: [MyModule1, MyModule2]}` - suppress eta reduction hints in the `MyModule1` and `MyModule2` modules.-* `- ignore: {within: MyModule.myFunction}` - don't give any hints in the function `MyModule.myFunction`.-* `- error: {within: MyModule.myFunction}` - any hint in the function `MyModule.myFunction` is an error.+* `- ignore: {within: MyModule.myDef}` - don't give any hints in the definition `MyModule.myDef`.+* `- error: {within: MyModule.myDef}` - any hint in the definition `MyModule.myDef` is an error. * `- error: {name: Use concatMap}` - the hint to use `concatMap` is an error (you may also use `warn` or `suggest` in place of `error` for other severity levels). These directives are applied in the order they are given, with later hints overriding earlier ones.@@ -373,12 +373,51 @@ You can customize the `Note:` for restricted modules, functions and extensions, by providing a `message` field (default: `may break the code`). -You can use [glob](https://en.wikipedia.org/wiki/Glob_(programming))-style wildcards to match on module names.+Other options are available: +- `asRequired`: boolean.++ If true, `as` alias is required. Ignored if `as` is empty.+- `importStyle`: one of `'qualified'`, `'unqualified'`, `'explicit'`,+ `'explicitOrQualified'`, `'unrestricted'`.++ The preferred import style.++ `explicitOrQualified` accepts both `import Foo (a,b,c)` and `import qualified Foo`, but not `import Foo` or `import Foo hiding (x)`.++ `explicit` is basically the same, but doesn't accept `import qualified`.++ `qualified` and `unqualified` do not care about the import list at all.+- `qualifiedStyle`: either `'pre'`, `'post'` or `'unrestricted'`; how should the module be qualified? This option also affects how suggestions are formatted.++For example:+ ```yaml - modules:+ - {name: [Data.Set, Data.HashSet], as: Set, asRequired: true}+ - {name: Debug, importStyle: explicitOrQualified}+ - {name: Unsafe, importStyle: qualified, qualifiedStyle: post, as: Unsafe}+ - {name: Prelude, importStyle: unqualified}+```++This:+* Requires `Data.Set` and `Data.HashSet` to be imported with alias `Set`; if imported without alias, a warning is generated.+* Says that `Debug` must be imported either qualified with post-qualification, i.e. `import Debug qualified`, or with an explicit import list, e.g. `Debug (debugPrint)`.+* Requires that `Unsafe` must always be imported qualified, and can't be aliased.+* Forbids `import qualified Prelude` and `import Prelude qualified` (with or without explicit import list).++You can match on module names using [glob](https://en.wikipedia.org/wiki/Glob_(programming))-style wildcards. Module names are treated like file paths, except that periods in module names are like directory separators in file paths. So `**.*Spec` will match `Spec`, `PreludeSpec`, `Data.ListSpec`, and many more. But `*Spec` won't match `Data.ListSpec` because of the separator. See [the filepattern library](https://hackage.haskell.org/package/filepattern) for a more thorough description of the matching.++Restrictions are unified between wildcard and specific matches. With `asRequired`, `importStyle` and `qualifiedStyle` fields, the more specific option takes precedence. The list fields are merged. With multiple wildcard matches, the precedence between them is not guaranteed (but in practice, names are sorted in the reverse lexicograpic order, and the first one wins -- which hopefully means the more specific one more often than not)++If the same module is specified multiple times, for `asRequired`, `importStyle`+and `qualifiedStyle` fields, only the first definition will take effect.++```yaml+- modules: - {name: [Data.Map, Data.Map.*], as: Map} - {name: Test.Hspec, within: **.*Spec }+ - {name: '**', importStyle: post} ``` ## Hacking HLint
+ data/hintrule-implies-classify.yaml view
@@ -0,0 +1,2 @@+- ignore: { }+- warn: {lhs: mapM, rhs: traverse}
data/hlint.yaml view
@@ -114,6 +114,10 @@ # - warn: {lhs: reverse (sort x), rhs: sortOn 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}+ - warn: {lhs: if a >= b then a else b, rhs: max a b}+ - warn: {lhs: if a > b then a else b, rhs: max a b}+ - warn: {lhs: if a <= b then a else b, rhs: min a b}+ - warn: {lhs: if a < b then a else b, rhs: min a b} # READ/SHOW@@ -127,6 +131,7 @@ # LIST - warn: {lhs: concat (map f x), rhs: concatMap f x}+ - warn: {lhs: concat (f <$> x), rhs: concatMap f x} - warn: {lhs: concat (fmap f x), rhs: concatMap f x} - hint: {lhs: "concat [a, b]", rhs: a ++ b} - hint: {lhs: map f (map g x), rhs: map (f . g) x, name: Use map once}@@ -232,6 +237,8 @@ - warn: {lhs: drop i x, rhs: x, side: isNegZero i, name: Drop on a non-positive} - warn: {lhs: last (scanl f z x), rhs: foldl f z x} - warn: {lhs: head (scanr f z x), rhs: foldr f z x}+ - warn: {lhs: "scanl (\\x _ -> a) b (replicate c d)", rhs: "take c (iterate (\\x -> a) b)"}+ - warn: {lhs: "foldl (\\x _ -> a) b [1..c]", rhs: "iterate (\\x -> a) b !! c"} - warn: {lhs: iterate id, rhs: repeat} - warn: {lhs: zipWith f (repeat x), rhs: map (f x)} - warn: {lhs: zipWith f y (repeat z), rhs: map (`f` z) y}@@ -255,12 +262,16 @@ - warn: {lhs: traverse pure, rhs: pure, name: "Traversable law"} - warn: {lhs: traverse (pure . f) x, rhs: pure (fmap f x), name: "Traversable law"} - warn: {lhs: sequenceA (map f x), rhs: traverse f x}+ - warn: {lhs: sequenceA (f <$> x), rhs: traverse f x} - warn: {lhs: sequenceA (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_ (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 (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 (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} @@ -455,7 +466,9 @@ - warn: {lhs: if x then return () else y, rhs: Control.Monad.unless x y, side: isAtom y} - warn: {lhs: sequence (map f x), rhs: mapM f x} - warn: {lhs: sequence_ (map f x), rhs: mapM_ f x}+ - warn: {lhs: sequence (f <$> x), rhs: mapM f x} - warn: {lhs: sequence (fmap f x), rhs: mapM f x}+ - warn: {lhs: sequence_ (f <$> x), 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_}@@ -504,6 +517,7 @@ # MONAD LIST + - warn: {lhs: unzip <$> mapM f x, 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}@@ -586,6 +600,7 @@ - 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 (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}@@ -613,10 +628,15 @@ - 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 (fmap g y), rhs: maybe x (f . g) y, name: Redundant fmap}+ - warn: {lhs: isJust (f <$> x), rhs: isJust x} - warn: {lhs: isJust (fmap f x), rhs: isJust x}+ - warn: {lhs: isNothing (f <$> x), 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 (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 (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}@@ -786,6 +806,10 @@ - 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: "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} # FOLDABLE + TUPLES @@ -838,10 +862,6 @@ - warn: {lhs: "Data.Map.Lazy.fromList []", rhs: Data.Map.Lazy.empty} - warn: {lhs: "Data.Map.Strict.fromList []", rhs: Data.Map.Strict.empty} - # TEMPLATE HASKELL-- - hint: {lhs: "TH.varE 'a", rhs: "[|a|]", name: Use TH quotation brackets}- - group: name: lens enabled: true@@ -877,6 +897,14 @@ - warn: {lhs: "either (const Nothing) Just", rhs: preview _Right} - group:+ name: use-th-quotes+ enabled: false+ imports:+ - package base+ rules:+ - hint: {lhs: "TH.varE 'a", rhs: "[|a|]", name: Use TH quotation brackets}++- group: name: attoparsec enabled: true imports:@@ -961,6 +989,10 @@ - warn: {lhs: "ifM a b (return False)", rhs: "(&&^) a b"} - warn: {lhs: "anyM id", rhs: "orM"} - warn: {lhs: "allM id", rhs: "andM"}+ - warn: {lhs: "allM f [a]", rhs: f a, name: Evaluate}+ - warn: {lhs: "allM f []", rhs: return True, name: Evaluate}+ - warn: {lhs: "anyM f [a]", rhs: f a, name: Evaluate}+ - warn: {lhs: "anyM f []", rhs: return False, name: Evaluate} - warn: {lhs: "either id id", rhs: "fromEither"} - warn: {lhs: "either (const Nothing) Just", rhs: "eitherToMaybe"} - warn: {lhs: "either (Left . a) Right", rhs: "mapLeft a"}@@ -1163,6 +1195,8 @@ # no = x ^^ 18.5 # instance Arrow (->) where first f = f *** id # yes = fromInteger 12 -- 12+# yes = if x * y > u * v then x * y else u * v -- max (x * y) (u * v)+# yes = scanl (\x _ -> x + 1) 7 (replicate 8 3) -- take 8 (iterate (\x -> x + 1) 7) # import Prelude hiding (catch); no = catch # import Control.Exception as E; no = E.catch # main = do f; putStrLn $ show x -- print x@@ -1215,6 +1249,8 @@ # foo = last (sortBy (compare `on` fst) xs) -- maximumBy (compare `on` fst) xs # g = \ f -> parseFile f >>= (\ cu -> return (f, cu)) # foo = bar $ \(x,y) -> x x y+# f = const [] . (>>= const Nothing) . const Nothing -- (const Nothing Control.Monad.<=< const Nothing)+# f = g . either Left h x -- (h =<< x) # foo = (\x -> f x >>= g) -- f Control.Monad.>=> g # foo = (\f -> h f >>= g) -- h Control.Monad.>=> g # foo = (\f -> h f >>= f)@@ -1252,8 +1288,6 @@ # issue1183 = (a >= 'a') && (a <= 'z') -- isAsciiLower a # issue1218 = uncurry (zipWith g) $ (a, b) -- zipWith g a b -# import Language.Haskell.TH\-# yes = varE 'foo -- [|foo|] # import Prelude \ # yes = flip mapM -- Control.Monad.forM # import Control.Monad \@@ -1281,6 +1315,17 @@ # import Prelude((==)) \ # import qualified Prelude as P \ # main = P.length xs == 0 -- P.null xs+# import Prelude () \+# main = length xs == 0 -- null xs+# import Prelude () \+# import Foo \+# main = length xs == 0 -- null xs+# import Prelude () \+# import Data.Text (length) \+# main = length xs == 0+# import Prelude () \+# import qualified Data.Text (length) \+# main = length xs == 0 -- null xs # main = hello .~ Just 12 -- hello ?~ 12 # foo = liftIO $ window `on` deleteEvent $ do a; b # no = sort <$> f input `shouldBe` sort <$> x
+ data/import_style.yaml view
@@ -0,0 +1,6 @@+- modules:+ - {name: HypotheticalModule1, as: HM1, asRequired: true}+ - {name: HypotheticalModule2, importStyle: explicitOrQualified}+ - {name: HypotheticalModule3, importStyle: qualified}+ - {name: 'HypotheticalModule3.*', importStyle: unqualified}+ - {name: 'HypotheticalModule3.OtherSubModule', importStyle: unrestricted, qualifiedStyle: post}
− data/wildcard-import.yaml
@@ -1,1 +0,0 @@-[ { modules: [ { name: Data.Map.*, as: Map } ] } ]
− data/wildcard.yaml
@@ -1,1 +0,0 @@-- ignore: { name: Use const, within: '**.*Spec' }
+ data/wildcards.yaml view
@@ -0,0 +1,31 @@+- modules:+ - { name: A, as: A }+ - { name: '*B', as: B }+ - { name: '**.C', as: C }+ - { name: '**.*D', as: D }+ - { name: E, within: E }+ - { name: F, within: '*F' }+ - { name: G, within: '**.G' }+ - { name: H, within: '**.*H' }+ - { name: '**.*U', within: '**.*U' }+- ignore:+ name: Use const+ within:+ - I+ - '*J'+ - '**.K'+ - '**.*L'+- extensions:+ - name: CPP+ within:+ - M+ - '*N'+ - '**.O'+ - '**.*P'+- functions:+ - name: read+ within:+ - Q+ - '*R'+ - '**.S'+ - '**.*T'
hlint.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.18 build-type: Simple name: hlint-version: 3.3.6+version: 3.4 license: BSD3 license-file: LICENSE category: Development author: Neil Mitchell <ndmitchell@gmail.com> maintainer: Neil Mitchell <ndmitchell@gmail.com>-copyright: Neil Mitchell 2006-2021+copyright: Neil Mitchell 2006-2022 synopsis: Source code suggestions description: HLint gives suggestions on how to improve your source code.@@ -29,6 +29,10 @@ data/*.hs data/*.yaml tests/*.test+ -- These are needed because of haskell/cabal#7862+ data/default.yaml+ data/hlint.yaml+ data/report_template.html extra-doc-files: README.md CHANGES.txt@@ -76,16 +80,16 @@ aeson >= 1.1.2.0, filepattern >= 0.1.1 - if !flag(ghc-lib) && impl(ghc >= 9.0.0) && impl(ghc < 9.1.0)+ if !flag(ghc-lib) && impl(ghc >= 9.2.2) && impl(ghc < 9.3.0) build-depends:- ghc == 9.0.*,+ ghc == 9.2.*, ghc-boot-th, ghc-boot else build-depends:- ghc-lib-parser == 9.0.*+ ghc-lib-parser == 9.2.* build-depends:- ghc-lib-parser-ex >= 9.0.0.4 && < 9.0.1+ ghc-lib-parser-ex >= 9.2.0.3 && < 9.2.1 if flag(gpl) build-depends: hscolour >= 1.21
src/Apply.hs view
@@ -72,7 +72,7 @@ removeRequiresExtensionNotes :: ModuleEx -> Idea -> Idea removeRequiresExtensionNotes m = \x -> x{ideaNote = filter keep $ ideaNote x} where- exts = Set.fromList $ concatMap snd $ languagePragmas $ pragmas $ ghcAnnotations m+ exts = Set.fromList $ concatMap snd $ languagePragmas $ pragmas (comments (hsmodAnn (unLoc . ghcModule $ m))) keep (RequiresExtension x) = not $ x `Set.member` exts keep _ = True @@ -90,10 +90,16 @@ Left (ParseError sl msg ctxt) -> pure $ Left $ classify [x | SettingClassify x <- s] $ rawIdeaN Error (adjustMessage msg) sl ctxt Nothing [] where+ -- important the message has "Parse error:" as the prefix so "--ignore=Parse error" works -- try and tidy up things like "parse error (mismatched brackets)" to not look silly adjustMessage :: String -> String- adjustMessage x = "Parse error: " ++ dropBrackets (dropPrefix "parse error " x)+ adjustMessage x = "Parse error: " ++ dropBrackets (+ case stripInfix "parse error " x of+ Nothing -> x+ Just (prefix, _) ->+ dropPrefix (prefix ++ "parse error ") x+ ) dropBrackets ('(':xs) | Just (xs,')') <- unsnoc xs = xs dropBrackets xs = xs
src/CmdLine.hs view
@@ -172,7 +172,7 @@ ,"To check all Haskell files in 'src' and generate a report type:" ," hlint src --report"] ] &= program "hlint" &= verbosity- &= summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2021")+ &= summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2022") where nam xs = nam_ xs &= name [head xs] nam_ xs = def &= explicit &= name xs@@ -207,13 +207,12 @@ cmdCpp :: Cmd -> CppFlags cmdCpp cmd | cmdCppSimple cmd = CppSimple- | Cpp `elem` (fst . snd) (cmdExtensions cmd) = Cpphs defaultCpphsOptions+ | otherwise = Cpphs defaultCpphsOptions {boolopts=defaultBoolOptions{hashline=False, stripC89=True, ansi=cmdCppAnsi cmd} ,includes = cmdCppInclude cmd ,preInclude = cmdCppFile cmd ,defines = ("__HLINT__","1") : [(a,drop1 b) | x <- cmdCppDefine cmd, let (a,b) = break (== '=') x] }- | otherwise = NoCpp -- | Determines whether to use colour or not.@@ -291,8 +290,8 @@ getExtensions args = (lang, foldl f (startExts, []) exts) where -- If a language specifier is provided e.g. Haskell98 or- -- Haskell2010 (and soon GHC2021), then it represents a- -- specific set of extensions which we default enable.+ -- Haskell2010 or GHC2021, then it represents a specific set+ -- of extensions which we default enable. -- If no language specifier is provided we construct our own -- set of extensions to default enable. The set that we@@ -310,7 +309,7 @@ langs, exts :: [String] (langs, exts) = partition (isJust . flip lookup ls) args- ls = [ (show x, x) | x <- [Haskell98, Haskell2010 {-, GHC2021-}] ]+ ls = [ (show x, x) | x <- [Haskell98, Haskell2010 , GHC2021] ] 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
@@ -43,7 +43,7 @@ ["- fixity: " ++ show (unsafePrettyPrint $ toFixitySig x)] renderSetting _ = [] -findSetting :: LHsDecl GhcPs -> [Setting]+findSetting :: LocatedA (HsDecl GhcPs) -> [Setting] findSetting (L _ (ValD _ x)) = findBind x findSetting (L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) = concatMap (findBind . unLoc) $ bagToList cid_binds@@ -57,26 +57,26 @@ findBind _ = [] findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]-findExp name vs (HsLam _ MG{mg_alts=L _ [L _ Match{m_pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=L _ (EmptyLocalBinds _)}}]})+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{} = [] findExp name vs HsVar{} = [] findExp name vs (OpApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $- HsApp noExtField x $ noLoc $ HsPar noExtField $ noLoc $ HsApp noExtField y $ noLoc $ mkVar "_hlint"+ HsApp EpAnnNotUsed x $ noLocA $ HsPar EpAnnNotUsed $ noLocA $ HsApp EpAnnNotUsed y $ noLocA $ mkVar "_hlint" findExp name vs bod = [SettingMatchExp $ HintRule Warning defaultHintName [] mempty (extendInstances lhs) (extendInstances $ fromParen rhs) Nothing] where- lhs = fromParen $ noLoc $ transform f bod- rhs = apps $ map noLoc $ HsVar noExtField (noLoc name) : map snd rep+ lhs = fromParen $ noLocA $ transform f bod+ rhs = apps $ map noLocA $ HsVar noExtField (noLocA name) : map snd rep rep = zip vs $ map (mkVar . pure) ['a'..] f (HsVar _ x) | Just y <- lookup (rdrNameStr x) rep = y- f (OpApp _ x dol y) | isDol dol = HsApp noExtField x $ noLoc $ HsPar noExtField y+ f (OpApp _ x dol y) | isDol dol = HsApp EpAnnNotUsed x $ noLocA $ HsPar EpAnnNotUsed y f x = x mkVar :: String -> HsExpr GhcPs-mkVar = HsVar noExtField . noLoc . Unqual . mkVarOcc+mkVar = HsVar noExtField . noLocA . Unqual . mkVarOcc
src/Config/Haskell.hs view
@@ -37,6 +37,7 @@ TypeAnnProvenance (L _ x) -> occNameStr x ModuleAnnProvenance -> "" + f :: LocatedA (HsExpr GhcPs) -> Maybe Classify f (L _ (HsLit _ (HsString _ (unpackFS -> s)))) | "hlint:" `isPrefixOf` lower s = case getSeverity a of Nothing -> errorOn expr "bad classify pragma"@@ -46,8 +47,8 @@ f (L _ (ExprWithTySig _ x _)) = f x f _ = Nothing -readComment :: Located AnnotationComment -> [Classify]-readComment c@(L pos AnnBlockComment{})+readComment :: LEpaComment -> [Classify]+readComment c@(L pos (EpaComment EpaBlockComment{} _)) | (hash, x) <- maybe (False, x) (True,) $ stripPrefix "#" x , x <- trim x , (hlint, x) <- word1 x@@ -73,15 +74,15 @@ readComment _ = [] -errorOn :: Outputable a => Located a -> String -> b+errorOn :: Outputable a => LocatedA a -> String -> b errorOn (L pos val) msg = exitMessageImpure $- showSrcSpan pos +++ showSrcSpan (locA pos) ++ ": Error while reading hint file, " ++ msg ++ "\n" ++ unsafePrettyPrint val -errorOnComment :: Located AnnotationComment -> String -> b+errorOnComment :: LEpaComment -> String -> b errorOnComment c@(L s _) msg = exitMessageImpure $ let isMultiline = isCommentMultiline c in- showSrcSpan s +++ showSrcSpan (RealSrcSpan (anchor s) Nothing) ++ ": Error while reading hint file, " ++ msg ++ "\n" ++ (if isMultiline then "{-" else "--") ++ commentText c ++ (if isMultiline then "-}" else "")
src/Config/Type.hs view
@@ -2,11 +2,13 @@ module Config.Type( Severity(..), Classify(..), HintRule(..), Note(..), Setting(..), Restrict(..), RestrictType(..), RestrictIdents(..), SmellType(..),+ RestrictImportStyle(..), QualifiedStyle(..), defaultHintName, isUnifyVar, showNotes, getSeverity, getRestrictType, getSmellType ) where import Data.Char import Data.List.Extra+import Data.Monoid import Prelude @@ -119,11 +121,28 @@ OnlyIdents x1 <> OnlyIdents x2 = OnlyIdents $ x1 <> x2 ri1 <> ri2 = error $ "Incompatible restrictions: " ++ show (ri1, ri2) +data RestrictImportStyle+ = ImportStyleQualified+ | ImportStyleUnqualified+ | ImportStyleExplicit+ | ImportStyleExplicitOrQualified+ | ImportStyleUnrestricted+ deriving Show++data QualifiedStyle+ = QualifiedStylePre+ | QualifiedStylePost+ | QualifiedStyleUnrestricted+ deriving Show+ data Restrict = Restrict {restrictType :: RestrictType ,restrictDefault :: Bool ,restrictName :: [String] ,restrictAs :: [String] -- for RestrictModule only, what module names you can import it as+ ,restrictAsRequired :: Alt Maybe Bool -- for RestrictModule only+ ,restrictImportStyle :: Alt Maybe RestrictImportStyle -- for RestrictModule only+ ,restrictQualifiedStyle :: Alt Maybe QualifiedStyle -- for RestrictModule only ,restrictWithin :: [(String, String)] ,restrictIdents :: RestrictIdents -- for RestrictModule only, what identifiers can be imported from it ,restrictMessage :: Maybe String
src/Config/Yaml.hs view
@@ -1,15 +1,30 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings, ViewPatterns, RecordWildCards, GeneralizedNewtypeDeriving, TupleSections #-}-{-# LANGUAGE CPP #-} module Config.Yaml( ConfigYaml,+ ConfigYamlBuiltin (..),+ ConfigYamlUser (..), readFileConfigYaml,- settingsFromConfigYaml+ settingsFromConfigYaml,+ isBuiltinYaml, ) where +#if defined(MIN_VERSION_aeson)+#if MIN_VERSION_aeson(2,0,0)+#define AESON 2+#else+#define AESON 1+#endif+#else+#define AESON 2+#endif++import GHC.Driver.Ppr+import GHC.Parser.Errors.Ppr import Config.Type-import Data.Either+import Data.Either.Extra import Data.Maybe import Data.List.Extra import Data.Tuple.Extra@@ -24,6 +39,7 @@ import Extension import GHC.Unit.Module import Data.Functor+import Data.Monoid import Data.Semigroup import Timing import Prelude@@ -31,7 +47,6 @@ import GHC.Data.Bag import GHC.Parser.Lexer import GHC.Utils.Error hiding (Severity)-import GHC.Utils.Outputable import GHC.Hs import GHC.Types.SrcLoc import GHC.Types.Name.Reader@@ -40,7 +55,7 @@ import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import Data.Char-#if MIN_VERSION_aeson(2,0,0)+#if AESON == 2 import Data.Aeson.KeyMap (toHashMapText) #endif @@ -71,7 +86,7 @@ #endif -#if !MIN_VERSION_aeson(2,0,0)+#if AESON == 1 toHashMapText :: a -> a toHashMapText = id #endif@@ -81,12 +96,20 @@ readFileConfigYaml :: FilePath -> Maybe String -> IO ConfigYaml readFileConfigYaml file contents = timedIO "Config" file $ do val <- case contents of- Nothing -> decodeFileEither file- Just src -> pure $ decodeEither' $ BS.pack src+ Nothing ->+ if isBuiltinYaml file+ then mapRight getConfigYamlBuiltin <$> decodeFileEither file+ else mapRight getConfigYamlUser <$> decodeFileEither file+ Just src -> pure $+ if isBuiltinYaml file+ then mapRight getConfigYamlBuiltin $ decodeEither' $ BS.pack src+ else mapRight getConfigYamlUser $ decodeEither' $ BS.pack src case val of Left e -> fail $ "Failed to read YAML configuration file " ++ file ++ "\n " ++ displayException e Right v -> pure v +isBuiltinYaml :: FilePath -> Bool+isBuiltinYaml = (== "data/hlint.yaml") --------------------------------------------------------------------- -- YAML DATA TYPE@@ -170,6 +193,12 @@ maybeParse parseValue Nothing = pure Nothing maybeParse parseValue (Just value) = Just <$> parseValue value +maybeParseEnum :: [(T.Text, a)] -> Maybe Val -> Parser (Maybe a)+maybeParseEnum _ Nothing = pure Nothing+maybeParseEnum dict (Just val) = case getVal val of+ String str | Just x <- lookup str dict -> pure $ Just x+ _ -> parseFail val . T.unpack $ "expected '" <> T.intercalate "', '" (fst <$> dict) <> "'"+ parseBool :: Val -> Parser Bool parseBool (getVal -> Bool b) = pure b parseBool v = parseFail v "Expected a Bool"@@ -203,30 +232,39 @@ case parser defaultParseFlags{enabledExtensions=configExtensions, disabledExtensions=[]} x of POk _ x -> pure x PFailed ps ->- let (_, errs) = getMessages ps baseDynFlags- errMsg = head (bagToList errs)- msg = GHC.Utils.Outputable.showSDoc baseDynFlags $ GHC.Utils.Error.pprLocErrMsg errMsg+ let errMsg = pprError . head . bagToList . snd $ getMessages ps+ msg = showSDoc baseDynFlags $ pprLocMsgEnvelope errMsg in parseFail v $ "Failed to parse " ++ msg ++ ", when parsing:\n " ++ x --------------------------------------------------------------------- -- YAML TO DATA TYPE -instance FromJSON ConfigYaml where+newtype ConfigYamlBuiltin = ConfigYamlBuiltin { getConfigYamlBuiltin :: ConfigYaml }+ deriving (Semigroup, Monoid)++newtype ConfigYamlUser = ConfigYamlUser { getConfigYamlUser :: ConfigYaml }+ deriving (Semigroup, Monoid)++instance FromJSON ConfigYamlBuiltin where parseJSON Null = pure mempty- parseJSON x = parseConfigYaml $ newVal x+ parseJSON x = ConfigYamlBuiltin <$> parseConfigYaml True (newVal x) -parseConfigYaml :: Val -> Parser ConfigYaml-parseConfigYaml v = do+instance FromJSON ConfigYamlUser where+ parseJSON Null = pure mempty+ parseJSON x = ConfigYamlUser <$> parseConfigYaml False (newVal x)++parseConfigYaml :: Bool -> Val -> Parser ConfigYaml+parseConfigYaml isBuiltin v = do vs <- parseArray v fmap ConfigYaml $ forM vs $ \o -> do (s, v) <- parseObject1 o case s of "package" -> ConfigPackage <$> parsePackage v- "group" -> ConfigGroup <$> parseGroup v+ "group" -> ConfigGroup <$> parseGroup isBuiltin v "arguments" -> ConfigSetting . map SettingArgument <$> parseArrayString v "fixity" -> ConfigSetting <$> parseFixity v "smell" -> ConfigSetting <$> parseSmell v- _ | isJust $ getSeverity s -> ConfigGroup . ruleToGroup <$> parseRule o+ _ | isJust $ getSeverity s -> ConfigGroup . ruleToGroup <$> parseRule isBuiltin o _ | Just r <- getRestrictType s -> ConfigSetting . map SettingRestrict <$> (parseArray v >>= mapM (parseRestrict r)) _ -> parseFail v "Expecting an object with a 'package' or 'group' key, a hint or a restriction" @@ -255,12 +293,12 @@ require _ _ (Just a) = pure a require val err Nothing = parseFail val err -parseGroup :: Val -> Parser Group-parseGroup v = do+parseGroup :: Bool -> Val -> Parser Group+parseGroup isBuiltin v = do groupName <- parseField "name" v >>= parseString groupEnabled <- parseFieldOpt "enabled" v >>= maybe (pure True) parseBool groupImports <- parseFieldOpt "imports" v >>= maybe (pure []) (parseArray >=> mapM parseImport)- groupRules <- parseFieldOpt "rules" v >>= maybe (pure []) parseArray >>= concatMapM parseRule+ groupRules <- parseFieldOpt "rules" v >>= maybe (pure []) parseArray >>= concatMapM (parseRule isBuiltin) allowFields v ["name","enabled","imports","rules"] pure Group{..} where@@ -273,8 +311,8 @@ ruleToGroup :: [Either HintRule Classify] -> Group ruleToGroup = Group "" True [] -parseRule :: Val -> Parser [Either HintRule Classify]-parseRule v = do+parseRule :: Bool -> Val -> Parser [Either HintRule Classify]+parseRule isBuiltin v = do (severity, v) <- parseSeverityKey v isRule <- isJust <$> parseFieldOpt "lhs" v if isRule then do@@ -286,7 +324,9 @@ allowFields v ["lhs","rhs","note","name","side"] let hintRuleScope = mempty- pure [Left HintRule{hintRuleSeverity=severity,hintRuleLHS=extendInstances lhs,hintRuleRHS=extendInstances rhs, ..}]+ pure $+ Left HintRule {hintRuleSeverity = severity, hintRuleLHS = extendInstances lhs, hintRuleRHS = extendInstances rhs, ..}+ : [Right $ Classify severity hintRuleName "" "" | not isBuiltin] else do names <- parseFieldOpt "name" v >>= maybe (pure []) parseArrayString within <- parseFieldOpt "within" v >>= maybe (pure [("","")]) (parseArray >=> concatMapM parseWithin)@@ -299,12 +339,26 @@ Just def -> do b <- parseBool def allowFields v ["default"]- pure $ Restrict restrictType b [] [] [] NoRestrictIdents Nothing+ pure $ Restrict restrictType b [] mempty mempty mempty mempty [] NoRestrictIdents Nothing Nothing -> do restrictName <- parseFieldOpt "name" v >>= maybe (pure []) parseArrayString restrictWithin <- parseFieldOpt "within" v >>= maybe (pure [("","")]) (parseArray >=> concatMapM parseWithin) restrictAs <- parseFieldOpt "as" v >>= maybe (pure []) parseArrayString+ restrictAsRequired <- parseFieldOpt "asRequired" v >>= fmap Alt . maybeParse parseBool+ restrictImportStyle <- parseFieldOpt "importStyle" v >>= fmap Alt . maybeParseEnum+ [ ("qualified" , ImportStyleQualified)+ , ("unqualified" , ImportStyleUnqualified)+ , ("explicit" , ImportStyleExplicit)+ , ("explicitOrQualified", ImportStyleExplicitOrQualified)+ , ("unrestricted" , ImportStyleUnrestricted)+ ]+ restrictQualifiedStyle <- parseFieldOpt "qualifiedStyle" v >>= fmap Alt . maybeParseEnum+ [ ("pre" , QualifiedStylePre)+ , ("post" , QualifiedStylePost)+ , ("unrestricted", QualifiedStyleUnrestricted)+ ] + restrictBadIdents <- parseFieldOpt "badidents" v restrictOnlyAllowedIdents <- parseFieldOpt "only" v restrictIdents <-@@ -318,7 +372,7 @@ allowFields v $ ["name", "within", "message"] ++ if restrictType == RestrictModule- then ["as", "badidents", "only"]+ then ["as", "asRequired", "importStyle", "qualifiedStyle", "badidents", "only"] else [] pure Restrict{restrictDefault=True,..} @@ -383,8 +437,8 @@ where scope'= asScope' packageMap' (map (fmap unextendInstances) groupImports) -asScope' :: Map.HashMap String [LImportDecl GhcPs] -> [Either String (LImportDecl GhcPs)] -> Scope-asScope' packages xs = scopeCreate (HsModule NoLayoutInfo Nothing Nothing (concatMap f xs) [] Nothing Nothing)+asScope' :: Map.HashMap String [LocatedA (ImportDecl GhcPs)] -> [Either String (LocatedA (ImportDecl GhcPs))] -> Scope+asScope' packages xs = scopeCreate (HsModule EpAnnNotUsed NoLayoutInfo Nothing Nothing (concatMap f xs) [] Nothing Nothing) where f (Right x) = [x] f (Left x) | Just pkg <- Map.lookup x packages = pkg
src/Extension.hs view
@@ -17,6 +17,9 @@ , QuasiQuotes -- breaks [x| ...], making whitespace free list comps break , {- DoRec , -} RecursiveDo -- breaks rec , LexicalNegation -- changes '-', see https://github.com/ndmitchell/hlint/issues/1230+ -- These next two change syntax significantly and must be opt-in.+ , OverloadedRecordDot+ , OverloadedRecordUpdate ] reallyBadExtensions =
src/Fixity.hs view
@@ -11,8 +11,10 @@ import GHC.Hs.Extension import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader-import GHC.Types.SrcLoc-import GHC.Types.Basic+import GHC.Types.Fixity+import GHC.Types.SourceText+import GHC.Parser.Annotation+import Language.Haskell.Syntax.Extension import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import Language.Haskell.GhclibParserEx.Fixity @@ -50,7 +52,7 @@ InfixN -> NotAssociative toFixitySig :: FixityInfo -> FixitySig GhcPs-toFixitySig (toFixity -> (name, x)) = FixitySig noExtField [noLoc $ mkRdrUnqual (mkVarOcc name)] x+toFixitySig (toFixity -> (name, x)) = FixitySig noExtField [noLocA $ mkRdrUnqual (mkVarOcc name)] x defaultFixities :: [FixityInfo] defaultFixities = map fromFixity $ customFixities ++ baseFixities ++ lensFixities ++ otherFixities
src/GHC/All.hs view
@@ -5,10 +5,11 @@ CppFlags(..), ParseFlags(..), defaultParseFlags, parseFlagsAddFixities, parseFlagsSetLanguage, ParseError(..), ModuleEx(..),- parseModuleEx, createModuleEx, ghcComments,+ parseModuleEx, createModuleEx, createModuleExWithFixities, ghcComments, modComments, parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode, ) where +import GHC.Driver.Ppr import Control.Monad.Trans.Except import Control.Monad.IO.Class import Util@@ -16,7 +17,6 @@ import Data.List.Extra import Timing import Language.Preprocessor.Cpphs-import qualified Data.Map as Map import System.IO.Extra import Fixity import Extension@@ -24,13 +24,14 @@ import GHC.Hs import GHC.Types.SrcLoc+import GHC.Types.Fixity import GHC.Utils.Error-import GHC.Utils.Outputable import GHC.Parser.Lexer hiding (context) import GHC.LanguageExtensions.Type-import GHC.Parser.Annotation import GHC.Driver.Session hiding (extensions)+import GHC.Parser.Errors.Ppr import GHC.Data.Bag+import Data.Generics.Uniplate.DataOnly import Language.Haskell.GhclibParserEx.GHC.Parser import Language.Haskell.GhclibParserEx.Fixity@@ -38,8 +39,7 @@ -- | What C pre processor should be used. data CppFlags- = NoCpp -- ^ No pre processing is done.- | CppSimple -- ^ Lines prefixed with @#@ are stripped.+ = CppSimple -- ^ Lines prefixed with @#@ are stripped. | Cpphs CpphsOptions -- ^ The @cpphs@ library is used. -- | Created with 'defaultParseFlags', used by 'parseModuleEx'.@@ -53,7 +53,7 @@ -- | Default value for 'ParseFlags'. defaultParseFlags :: ParseFlags-defaultParseFlags = ParseFlags NoCpp Nothing defaultExtensions [] defaultFixities+defaultParseFlags = ParseFlags CppSimple Nothing defaultExtensions [] defaultFixities -- | Given some fixities, add them to the existing fixities in 'ParseFlags'. parseFlagsAddFixities :: [FixityInfo] -> ParseFlags -> ParseFlags@@ -64,7 +64,6 @@ runCpp :: CppFlags -> FilePath -> String -> IO String-runCpp NoCpp _ x = pure x runCpp CppSimple _ x = pure $ unlines [if "#" `isPrefixOf` trimStart x then "" else x | x <- lines x] runCpp (Cpphs o) file x = dropLine <$> runCpphs o file x where@@ -83,35 +82,29 @@ } -- | Result of 'parseModuleEx', representing a parsed module.-data ModuleEx = ModuleEx {+newtype ModuleEx = ModuleEx { ghcModule :: Located HsModule- , ghcAnnotations :: ApiAnns } --- | Extract a list of all of a parsed module's comments.-ghcComments :: ModuleEx -> [Located AnnotationComment]-ghcComments m =- map realToLoc $- concat (Map.elems $ apiAnnComments (ghcAnnotations m)) ++- apiAnnRogueComments (ghcAnnotations m)- where- -- TODO (2020-10-03, SF): This utility is repeated in- -- ApiAnnotation.hs. Consider doing something in- -- ghc-lib-parser-ex to clean this up.- realToLoc :: RealLocated a -> Located a- realToLoc (L r x) = L (RealSrcSpan r Nothing) x+-- | Extract a complete list of all the comments in a module.+ghcComments :: ModuleEx -> [LEpaComment]+ghcComments = universeBi . ghcModule +-- | Extract just the list of a modules' leading comments (pragmas).+modComments :: ModuleEx -> EpAnnComments+modComments = comments . hsmodAnn . unLoc . ghcModule+ -- | The error handler invoked when GHC parsing has failed. ghcFailOpParseModuleEx :: String -> FilePath -> String- -> (SrcSpan, GHC.Utils.Error.MsgDoc)+ -> (SrcSpan, SDoc) -> IO (Either ParseError ModuleEx) ghcFailOpParseModuleEx ppstr file str (loc, err) = do let pe = case loc of RealSrcSpan r _ -> context (srcSpanStartLine r) ppstr _ -> ""- msg = GHC.Utils.Outputable.showSDoc baseDynFlags err+ msg = GHC.Driver.Ppr.showSDoc baseDynFlags err pure $ Left $ ParseError loc msg pe -- GHC extensions to enable/disable given HSE parse flags.@@ -119,7 +112,7 @@ ghcExtensionsFromParseFlags ParseFlags{enabledExtensions=es, disabledExtensions=ds}= (es, ds) -- GHC fixities given HSE parse flags.-ghcFixitiesFromParseFlags :: ParseFlags -> [(String, Fixity)]+ghcFixitiesFromParseFlags :: ParseFlags -> [(String, GHC.Types.Fixity.Fixity)] ghcFixitiesFromParseFlags = map toFixity . fixities -- These next two functions get called frorm 'Config/Yaml.hs' for user@@ -149,13 +142,16 @@ POk pst a -> POk pst $ applyFixities fixities a f@PFailed{} -> f --- | Create a 'ModuleEx' from GHC annotations and module tree. It--- is assumed the incoming parse module has not been adjusted to--- account for operator fixities (it uses the HLint default fixities).-createModuleEx :: ApiAnns -> Located HsModule -> ModuleEx-createModuleEx anns ast =- ModuleEx (applyFixities (fixitiesFromModule ast ++ map toFixity defaultFixities) ast) anns+-- | Create a 'ModuleEx' from a GHC module. It is assumed the incoming+-- parsed module has not been adjusted to account for operator+-- fixities (it uses the HLint default fixities).+createModuleEx :: Located HsModule -> ModuleEx+createModuleEx = createModuleExWithFixities (map toFixity defaultFixities) +createModuleExWithFixities :: [(String, Fixity)] -> Located HsModule -> ModuleEx+createModuleExWithFixities fixities ast =+ ModuleEx (applyFixities (fixitiesFromModule ast ++ fixities) ast)+ -- | 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@@ -185,20 +181,14 @@ -- Done with pragmas. Proceed to parsing. case fileToModule file str dynFlags of POk s a -> do- let errs = bagToList . snd $ getMessages s dynFlags+ let errs = bagToList . snd $ getMessages s if not $ null errs then ExceptT $ parseFailureErr dynFlags str file str errs else do- let anns = ApiAnns {- apiAnnItems = Map.fromListWith (++) $ annotations s- , apiAnnEofPos = Nothing- , apiAnnComments = Map.fromListWith (++) $ annotations_comments s- , apiAnnRogueComments = comment_q s- } let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags- pure $ ModuleEx (applyFixities fixes a) anns+ pure $ ModuleEx (applyFixities fixes a) PFailed s ->- ExceptT $ parseFailureErr dynFlags str file str $ bagToList . snd $ getMessages s dynFlags+ ExceptT $ parseFailureErr dynFlags str file str $ bagToList . snd $ getMessages s where -- If parsing pragmas fails, synthesize a parse error from the -- error message.@@ -207,11 +197,9 @@ in ParseError (mkSrcSpan loc loc) msg src parseFailureErr dynFlags ppstr file str errs =- let errMsg = head errs+ let errMsg = pprError (head errs) loc = errMsgSpan errMsg- style = mkErrStyle (errMsgContext errMsg)- ctx = initSDocContext dynFlags style- doc = formatErrDoc ctx (errMsgDoc errMsg)+ doc = pprLocMsgEnvelope 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/ApiAnnotation.hs view
@@ -1,6 +1,6 @@ module GHC.Util.ApiAnnotation (- comment, commentText, isCommentMultiline+ comment_, commentText, isCommentMultiline , pragmas, flags, languagePragmas , mkFlags, mkLanguagePragmas , extensions@@ -32,46 +32,40 @@ trimCommentDelims = trimCommentEnd . trimCommentStart -- | A comment as a string.-comment :: Located AnnotationComment -> String-comment (L _ (AnnBlockComment s)) = s-comment (L _ (AnnLineComment s)) = s-comment (L _ (AnnDocOptions s)) = s-comment (L _ (AnnDocCommentNamed s)) = s-comment (L _ (AnnDocCommentPrev s)) = s-comment (L _ (AnnDocCommentNext s)) = s-comment (L _ (AnnDocSection _ s)) = s+comment_ :: LEpaComment -> String+comment_ (L _ (EpaComment (EpaBlockComment s ) _)) = s+comment_ (L _ (EpaComment (EpaLineComment s) _)) = s+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 _)) = "" -- | The comment string with delimiters removed.-commentText :: Located AnnotationComment -> String-commentText = trimCommentDelims . comment+commentText :: LEpaComment -> String+commentText = trimCommentDelims . comment_ -isCommentMultiline :: Located AnnotationComment -> Bool-isCommentMultiline (L _ (AnnBlockComment _)) = True+isCommentMultiline :: LEpaComment -> Bool+isCommentMultiline (L _ (EpaComment (EpaBlockComment _) _)) = True isCommentMultiline _ = False --- GHC parse trees don't contain pragmas. We work around this with--- (nasty) parsing of comments.---- Pragmas. Comments not associated with a span in the annotations--- that have the form @{-# ...#-}@.-pragmas :: ApiAnns -> [(Located AnnotationComment, String)]-pragmas anns =- -- 'ApiAnns' stores pragmas in reverse order to how they were+-- Pragmas have the form @{-# ...#-}@.+pragmas :: EpAnnComments -> [(LEpaComment, String)]+pragmas x =+ -- 'EpaAnnComments' stores pragmas in reverse order to how they were -- encountered in the source file with the last at the head of the -- list (makes sense when you think about it). reverse- [ (realToLoc c, s) |- c@(L _ (AnnBlockComment comm)) <- apiAnnRogueComments anns+ [ (c, s) |+ c@(L _ (EpaComment (EpaBlockComment comm) _)) <- priorComments x , let body = trimCommentDelims comm , Just rest <- [stripSuffix "#" =<< stripPrefix "#" body] , let s = trim rest ]- where- realToLoc :: RealLocated a -> Located a- realToLoc (L r x) = L (RealSrcSpan r Nothing) x -- All the extensions defined to be used.-extensions :: ApiAnns -> Set.Set Extension+extensions :: EpAnnComments -> Set.Set Extension extensions = Set.fromList . mapMaybe readExtension . concatMap snd . languagePragmas . pragmas @@ -82,11 +76,9 @@ (str_pref, rest) = splitAt (length pref') str in if lower str_pref == pref' then Just rest else Nothing --- Flags. The first element of the pair is the (located) annotation--- comment that sets the flags enumerated in the second element of the--- pair.-flags :: [(Located AnnotationComment, String)]- -> [(Located AnnotationComment, [String])]+-- Flags. The first element of the pair is the comment that+-- sets the flags enumerated in the second element of the pair.+flags :: [(LEpaComment, String)] -> [(LEpaComment, [String])] flags ps = -- Old versions of GHC accepted 'OPTIONS' rather than 'OPTIONS_GHC' (but -- this is deprecated).@@ -98,18 +90,17 @@ -- Language pragmas. The first element of the -- pair is the (located) annotation comment that enables the -- pragmas enumerated by he second element of the pair.-languagePragmas :: [(Located AnnotationComment, String)]- -> [(Located AnnotationComment, [String])]+languagePragmas :: [(LEpaComment, String)] -> [(LEpaComment, [String])] languagePragmas ps = [(c, exts) | (c, s) <- ps , Just rest <- [stripPrefixCI "LANGUAGE " s] , let exts = map trim (splitOn "," rest)] -- Given a list of flags, make a GHC options pragma.-mkFlags :: SrcSpan -> [String] -> Located AnnotationComment-mkFlags loc flags =- L loc $ AnnBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")+mkFlags :: Anchor -> [String] -> LEpaComment+mkFlags anc flags =+ L anc $ EpaComment (EpaBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")) (anchor anc) -mkLanguagePragmas :: SrcSpan -> [String] -> Located AnnotationComment-mkLanguagePragmas loc exts =- L loc $ AnnBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")+mkLanguagePragmas :: Anchor -> [String] -> LEpaComment+mkLanguagePragmas anc exts =+ L anc $ EpaComment (EpaBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")) (anchor anc)
src/GHC/Util/Brackets.hs view
@@ -5,7 +5,7 @@ import GHC.Hs import GHC.Types.SrcLoc-import GHC.Types.Basic+import GHC.Types.SourceText import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Refact.Types @@ -20,7 +20,7 @@ needBracket :: Int -> a -> a -> Bool findType :: a -> RType -instance Brackets (LHsExpr GhcPs) where+instance Brackets (LocatedA (HsExpr GhcPs)) where -- When GHC parses a section in concrete syntax, it will produce an -- 'HsPar (Section[L|R])'. There is no concrete syntax that will -- result in a "naked" section. Consequently, given an expression,@@ -31,7 +31,7 @@ remParen (L _ (HsPar _ x)) = Just x remParen _ = Nothing - addParen e = noLoc $ HsPar noExtField e+ addParen e = noLocA $ HsPar EpAnnNotUsed e isAtom (L _ x) = case x of HsVar{} -> True@@ -98,15 +98,15 @@ -- -- (f \x -> x) *> ... -- (f do x) *> ...-isAtomOrApp :: LHsExpr GhcPs -> Bool+isAtomOrApp :: LocatedA (HsExpr GhcPs) -> Bool isAtomOrApp x | isAtom x = True isAtomOrApp (L _ (HsApp _ _ x)) = isAtomOrApp x isAtomOrApp _ = False -instance Brackets (Located (Pat GhcPs)) where+instance Brackets (LocatedA (Pat GhcPs)) where remParen (L _ (ParPat _ x)) = Just x remParen _ = Nothing- addParen e = noLoc $ ParPat noExtField e+ addParen e = noLocA $ ParPat EpAnnNotUsed e isAtom (L _ x) = case x of ParPat{} -> True@@ -114,7 +114,7 @@ ListPat{} -> True -- This is technically atomic, but lots of people think it shouldn't be ConPat _ _ RecCon{} -> False- ConPat _ _ (PrefixCon []) -> True+ ConPat _ _ (PrefixCon _ []) -> True VarPat{} -> True WildPat{} -> True SumPat{} -> True@@ -141,10 +141,10 @@ findType _ = Pattern -instance Brackets (LHsType GhcPs) where+instance Brackets (LocatedA (HsType GhcPs)) where remParen (L _ (HsParTy _ x)) = Just x remParen _ = Nothing- addParen e = noLoc $ HsParTy noExtField e+ addParen e = noLocA $ HsParTy EpAnnNotUsed e isAtom (L _ x) = case x of HsParTy{} -> True
src/GHC/Util/FreeVars.hs view
@@ -90,12 +90,12 @@ bb = allVars b -- Get an `OccName` out of a reader name.-unqualNames :: Located RdrName -> [OccName]+unqualNames :: LocatedN RdrName -> [OccName] unqualNames (L _ (Unqual x)) = [x] unqualNames (L _ (Exact x)) = [nameOccName x] unqualNames _ = [] -instance FreeVars (LHsExpr GhcPs) where+instance FreeVars (LocatedA (HsExpr GhcPs)) where freeVars (L _ (HsVar _ x)) = Set.fromList $ unqualNames x -- Variable. freeVars (L _ (HsUnboundVar _ x)) = Set.fromList [x] -- Unbound variable; also used for "holes". freeVars (L _ (HsLam _ mg)) = free (allVars mg) -- Lambda abstraction. Currently always a single match.@@ -104,10 +104,13 @@ freeVars (L _ (HsLet _ binds e)) = inFree binds e -- Let (rec). freeVars (L _ (HsDo _ ctxt (L _ stmts))) = free (allVars stmts) -- Do block. freeVars (L _ (RecordCon _ _ (HsRecFields flds _))) = Set.unions $ map freeVars flds -- Record construction.- freeVars (L _ (RecordUpd _ e flds)) = Set.unions $ freeVars e : map freeVars flds -- Record update.+ freeVars (L _ (RecordUpd _ e flds)) =+ case flds of+ 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 v]+ freeVars (L _ (HsBracket _ (VarBr _ _ v))) = Set.fromList [occName (unLoc v)] freeVars (L _ HsConLikeOut{}) = mempty -- After typechecker. freeVars (L _ HsRecFld{}) = mempty -- Variable pointing to a record selector.@@ -148,22 +151,25 @@ freeVars e = freeVars $ children e -instance FreeVars (LHsTupArg GhcPs) where- freeVars (L _ (Present _ args)) = freeVars args+instance FreeVars (HsTupArg GhcPs) where+ freeVars (Present _ args) = freeVars args freeVars _ = mempty -instance FreeVars (LHsRecField GhcPs (LHsExpr GhcPs)) where- freeVars o@(L _ (HsRecField x _ True)) = Set.singleton $ occName $ unLoc $ rdrNameFieldOcc $ unLoc x -- a pun- freeVars o@(L _ (HsRecField _ x _)) = freeVars x+instance FreeVars (LocatedA (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 (LHsRecUpdField GhcPs) where- freeVars (L _ (HsRecField _ x _)) = freeVars x+instance FreeVars (LocatedA (HsRecField' (AmbiguousFieldOcc GhcPs) (LocatedA (HsExpr GhcPs)))) where+ freeVars (L _ (HsRecField _ _ x _)) = freeVars x -instance AllVars (Located (Pat GhcPs)) where+instance FreeVars (LocatedA (HsRecField' (FieldLabelStrings GhcPs) (LocatedA (HsExpr GhcPs)))) where+ freeVars (L _ (HsRecField _ _ 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 (noLoc $ VarPat noExtField n :: LPat GhcPs) <> allVars x -- As pattern.+ allVars (L _ (AsPat _ n x)) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) <> allVars x -- As pattern. allVars (L _ (ConPat _ _ (RecCon (HsRecFields flds _)))) = allVars flds- allVars (L _ (NPlusKPat _ n _ _ _ _)) = allVars (noLoc $ VarPat noExtField n :: LPat GhcPs) -- n+k pattern.+ 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.@@ -182,60 +188,60 @@ allVars p = allVars $ children p -instance AllVars (LHsRecField GhcPs (Located (Pat GhcPs))) where- allVars (L _ (HsRecField _ x _)) = allVars x+instance AllVars (LocatedA (HsRecField GhcPs (LocatedA (Pat GhcPs)))) where+ allVars (L _ (HsRecField _ _ x _)) = allVars x -instance AllVars (LStmt GhcPs (LHsExpr GhcPs)) where+instance AllVars (LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))) where allVars (L _ (LastStmt _ expr _ _)) = freeVars_ expr -- The last stmt of a ListComp, MonadComp, DoExpr,MDoExpr. allVars (L _ (BindStmt _ pat expr)) = allVars pat <> freeVars_ expr -- A generator e.g. x <- [1, 2, 3]. allVars (L _ (BodyStmt _ expr _ _)) = freeVars_ expr -- A boolean guard e.g. even x. allVars (L _ (LetStmt _ binds)) = allVars binds -- A local declaration e.g. let y = x + 1- allVars (L _ (TransStmt _ _ stmts _ using by _ _ fmap_)) = allVars stmts <> freeVars_ using <> maybe mempty freeVars_ by <> freeVars_ (noLoc fmap_ :: Located (HsExpr GhcPs)) -- Apply a function to a list of statements in order.- allVars (L _ (RecStmt _ stmts _ _ _ _ _)) = allVars stmts -- A recursive binding for a group of arrows.+ allVars (L _ (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 (LHsLocalBinds GhcPs) where- allVars (L _ (HsValBinds _ (ValBinds _ binds _))) = allVars (bagToList binds) -- Value bindings.- allVars (L _ (HsIPBinds _ (IPBinds _ binds))) = allVars binds -- Implicit parameter bindings.- allVars (L _ EmptyLocalBinds{}) = mempty -- The case of no local bindings (signals the empty `let` or `where` clause).+instance AllVars (HsLocalBinds GhcPs) where+ allVars (HsValBinds _ (ValBinds _ binds _)) = allVars (bagToList binds) -- Value bindings.+ allVars (HsIPBinds _ (IPBinds _ binds)) = allVars binds -- Implicit parameter bindings.+ allVars EmptyLocalBinds{} = mempty -- The case of no local bindings (signals the empty `let` or `where` clause). allVars _ = mempty -- extension points -instance AllVars (LIPBind GhcPs) where+instance AllVars (LocatedA (IPBind GhcPs)) where allVars (L _ (IPBind _ _ e)) = freeVars_ e -instance AllVars (LHsBind GhcPs) where- allVars (L _ FunBind{fun_id=n, fun_matches=MG{mg_alts=(L _ ms)}}) = allVars (noLoc $ VarPat noExtField n :: LPat GhcPs) <> allVars ms -- Function bindings and simple variable bindings e.g. f x = e, f !x = 3, f = e, !x = e, x `f` y = e+instance AllVars (LocatedA (HsBindLR GhcPs GhcPs)) where+ allVars (L _ FunBind{fun_id=n, fun_matches=MG{mg_alts=(L _ ms)}}) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) <> allVars ms -- Function bindings and simple variable bindings e.g. f x = e, f !x = 3, f = e, !x = e, x `f` y = e allVars (L _ PatBind{pat_lhs=n, pat_rhs=grhss}) = allVars n <> allVars grhss -- Ctor patterns and some other interesting cases e.g. Just x = e, (x) = e, x :: Ty = e. allVars (L _ (PatSynBind _ PSB{})) = mempty -- Come back to it. allVars (L _ VarBind{}) = mempty -- Typechecker. allVars (L _ AbsBinds{}) = mempty -- Not sure but I think renamer. -instance AllVars (MatchGroup GhcPs (LHsExpr GhcPs)) where+instance AllVars (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where allVars (MG _ _alts@(L _ alts) _) = inVars (foldMap (allVars . m_pats) ms) (allVars (map m_grhss ms)) where ms = map unLoc alts -instance AllVars (LMatch GhcPs (LHsExpr GhcPs)) where- allVars (L _ (Match _ FunRhs {mc_fun=name} pats grhss)) = allVars (noLoc $ VarPat noExtField name :: LPat GhcPs) <> allVars pats <> allVars grhss -- A pattern matching on an argument of a function binding.+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. instance AllVars (HsStmtContext GhcPs) where- allVars (PatGuard FunRhs{mc_fun=n}) = allVars (noLoc $ VarPat noExtField n :: LPat GhcPs)+ allVars (PatGuard FunRhs{mc_fun=n}) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) allVars ParStmtCtxt{} = mempty -- Come back to it. allVars TransStmtCtxt{} = mempty -- Come back to it. allVars _ = mempty -instance AllVars (GRHSs GhcPs (LHsExpr GhcPs)) where+instance AllVars (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where allVars (GRHSs _ grhss binds) = inVars binds (mconcatMap allVars grhss) -instance AllVars (LGRHS GhcPs (LHsExpr GhcPs)) where+instance AllVars (Located (GRHS GhcPs (LocatedA (HsExpr GhcPs)))) where allVars (L _ (GRHS _ guards expr)) = Vars (bound gs) (free gs ^+ (freeVars expr ^- bound gs)) where gs = allVars guards -instance AllVars (LHsDecl GhcPs) where- allVars (L l (ValD _ bind)) = allVars (L l bind :: LHsBind GhcPs)+instance AllVars (LocatedA (HsDecl GhcPs)) where+ allVars (L l (ValD _ bind)) = allVars (L l bind :: LocatedA (HsBindLR GhcPs GhcPs)) allVars _ = mempty
src/GHC/Util/HsExpr.hs view
@@ -37,7 +37,7 @@ import Data.Tuple.Extra import Data.Maybe -import Refact (substVars, toSS)+import Refact (substVars, toSSA) import Refact.Types hiding (SrcSpan, Match) import qualified Refact.Types as R (SrcSpan) @@ -49,7 +49,7 @@ -- | 'dotApp a b' makes 'a . b'. dotApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs-dotApp x y = noLoc $ OpApp noExtField x (noLoc $ HsVar noExtField (noLoc $ mkVarUnqual (fsLit "."))) y+dotApp x y = noLocA $ OpApp EpAnnNotUsed 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 +58,7 @@ -- | @lambda [p0, p1..pn] body@ makes @\p1 p1 .. pn -> body@ lambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs-lambda vs body = noLoc $ HsLam noExtField (MG noExtField (noLoc [noLoc $ Match noExtField LambdaExpr vs (GRHSs noExtField [noLoc $ GRHS noExtField [] body] (noLoc $ EmptyLocalBinds noExtField))]) Generated)+lambda vs body = noLocA $ HsLam noExtField (MG noExtField (noLocA [noLocA $ Match EpAnnNotUsed LambdaExpr vs (GRHSs emptyComments [noLoc $ GRHS EpAnnNotUsed [] body] (EmptyLocalBinds noExtField))]) Generated) -- | 'paren e' wraps 'e' in parens if 'e' is non-atomic. paren :: LHsExpr GhcPs -> LHsExpr GhcPs@@ -72,7 +72,7 @@ apps :: [LHsExpr GhcPs] -> LHsExpr GhcPs-apps = foldl1' mkApp where mkApp x y = noLoc (HsApp noExtField x y)+apps = foldl1' mkApp where mkApp x y = noLocA (HsApp EpAnnNotUsed x y) fromApps :: LHsExpr GhcPs -> [LHsExpr GhcPs] fromApps (L _ (HsApp _ x y)) = fromApps x ++ [y]@@ -86,7 +86,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 noExtField x y) (descendAppsM f x) (f y)+descendAppsM f (L l (HsApp _ x y)) = liftA2 (\x y -> L l $ HsApp EpAnnNotUsed 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 +117,15 @@ -- A list of application, with any necessary brackets. appsBracket :: [LHsExpr GhcPs] -> LHsExpr GhcPs appsBracket = foldl1 mkApp- where mkApp x y = rebracket1 (noLoc $ HsApp noExtField x y)+ where mkApp x y = rebracket1 (noLocA $ HsApp EpAnnNotUsed x y) simplifyExp :: LHsExpr GhcPs -> LHsExpr GhcPs -- Replace appliciations 'f $ x' with 'f (x)'.-simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp noExtField x (noLoc (HsPar noExtField y)))-simplifyExp e@(L _ (HsLet _ (L _ (HsValBinds _ (ValBinds _ binds []))) z)) =+simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp EpAnnNotUsed x (noLocA (HsPar EpAnnNotUsed y)))+simplifyExp e@(L _ (HsLet _ ((HsValBinds _ (ValBinds _ binds []))) z)) = -- An expression of the form, 'let x = y in z'. case bagToList binds of- [L _ (FunBind _ _ (MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _) [] (GRHSs _[L _ (GRHS _ [] y)] (L _ (EmptyLocalBinds _))))]) _) _)]+ [L _ (FunBind _ _ (MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _) [] (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 ->@@ -177,7 +177,7 @@ , vars e `disjoint` [v] , L _ (HsVar _ (L _ fname)) <- f , isSymOcc $ rdrNameOcc fname- = let res = noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField e f+ = let res = noLocA $ HsPar EpAnnNotUsed $ noLocA $ SectionL EpAnnNotUsed e f in (res, \s -> [Replace Expr s [] (unsafePrettyPrint res)]) -- @\vs v -> f x v@ ==> @\vs -> f x@@@ -198,7 +198,7 @@ -- lexeme, or it all gets too complex). niceLambdaR [x] (view -> App2 op@(L _ (HsVar _ (L _ tag))) l r) | isLexeme r, view l == Var_ x, x `notElem` vars r, allowRightSection (occNameStr tag) =- let e = rebracket1 $ addParen (noLoc $ SectionR noExtField op r)+ let e = rebracket1 $ addParen (noLocA $ SectionR EpAnnNotUsed 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@@ -217,7 +217,7 @@ factor _ = Nothing mkRefact :: [LHsExpr GhcPs] -> R.SrcSpan -> Refactoring R.SrcSpan mkRefact subts s =- let tempSubts = zipWith (\a b -> (a, toSS b)) substVars subts+ let tempSubts = zipWith (\a b -> (a, toSSA b)) substVars subts template = dotApps (map (strToVar . fst) tempSubts) in Replace Expr s tempSubts (unsafePrettyPrint template) -- Rewrite @\x y -> x + y@ as @(+)@.@@ -227,31 +227,32 @@ niceLambdaR [x, y] (view -> App2 op (view -> Var_ y1) (view -> Var_ x1)) | x == x1, y == y1, vars op `disjoint` [x, y] = ( gen op- , \s -> [Replace Expr s [("x", toSS op)] (unsafePrettyPrint $ gen (strToVar "x"))]+ , \s -> [Replace Expr s [("x", toSSA op)] (unsafePrettyPrint $ gen (strToVar "x"))] ) where- gen = noLoc . HsApp noExtField (strToVar "flip")+ gen :: LHsExpr GhcPs -> LHsExpr GhcPs+ gen = noLocA . HsApp EpAnnNotUsed (strToVar "flip") . if isAtom op then id else addParen -- We're done factoring, but have no variables left, so we shouldn't make a lambda. -- @\ -> e@ ==> @e@-niceLambdaR [] e = (e, \s -> [Replace Expr s [("a", toSS e)] "a"])+niceLambdaR [] e = (e, \s -> [Replace Expr s [("a", toSSA e)] "a"]) -- Base case. Just a good old fashioned lambda. niceLambdaR ss e =- let grhs = noLoc $ GRHS noExtField [] e :: LGRHS GhcPs (LHsExpr GhcPs)- grhss = GRHSs {grhssExt = noExtField, grhssGRHSs=[grhs], grhssLocalBinds=noLoc $ EmptyLocalBinds noExtField}- match = noLoc $ Match {m_ext=noExtField, m_ctxt=LambdaExpr, m_pats=map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs)- matchGroup = MG {mg_ext=noExtField, mg_origin=Generated, mg_alts=noLoc [match]}- in (noLoc $ HsLam noExtField matchGroup, const [])+ let grhs = noLoc $ 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]}+ in (noLocA $ HsLam noExtField matchGroup, const []) -- 'case' and 'if' expressions have branches, nothing else does (this -- doesn't consider 'HsMultiIf' perhaps it should?). replaceBranches :: LHsExpr GhcPs -> ([LHsExpr GhcPs], [LHsExpr GhcPs] -> LHsExpr GhcPs)-replaceBranches (L l (HsIf _ a b c)) = ([b, c], \[b, c] -> L l (HsIf noExtField a b c))+replaceBranches (L l (HsIf _ a b c)) = ([b, c], \[b, c] -> L l (HsIf EpAnnNotUsed a b c)) replaceBranches (L s (HsCase _ a (MG _ (L l bs) FromSource))) =- (concatMap f bs, \xs -> L s (HsCase noExtField a (MG noExtField (L l (g bs xs)) Generated)))+ (concatMap f bs, \xs -> L s (HsCase EpAnnNotUsed a (MG noExtField (L l (g bs xs)) Generated))) where f :: LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs] f (L _ (Match _ CaseAlt _ (GRHSs _ xs _))) = [x | (L _ (GRHS _ _ x)) <- xs]@@ -259,7 +260,7 @@ g :: [LMatch GhcPs (LHsExpr GhcPs)] -> [LHsExpr GhcPs] -> [LMatch GhcPs (LHsExpr GhcPs)] g (L s1 (Match _ CaseAlt a (GRHSs _ ns b)) : rest) xs =- L s1 (Match noExtField CaseAlt a (GRHSs noExtField [L a (GRHS noExtField gs x) | (L a (GRHS _ gs _), x) <- zip ns as] b)) : g rest bs+ L s1 (Match EpAnnNotUsed CaseAlt a (GRHSs emptyComments [L a (GRHS EpAnnNotUsed 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"
src/GHC/Util/Scope.hs view
@@ -1,5 +1,5 @@ -{-# LANGUAGE ViewPatterns #-}+{-# Language ViewPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Util.Scope (@@ -9,7 +9,7 @@ import GHC.Hs import GHC.Types.SrcLoc-import GHC.Types.Basic+import GHC.Types.SourceText import GHC.Unit.Module import GHC.Data.FastString import GHC.Types.Name.Reader@@ -38,11 +38,13 @@ -- The import declaraions contained by the module 'xs'. res :: [LImportDecl GhcPs]- res = [x | x <- hsmodImports xs , pkg x /= Just (StringLiteral NoSourceText (fsLit "hint"))]+ res = [x | x <- hsmodImports xs+ , pkg x /= Just (StringLiteral NoSourceText (fsLit "hint") Nothing)+ ] -- Mock up an import declaraion corresponding to 'import Prelude'. prelude :: LImportDecl GhcPs- prelude = noLoc $ simpleImportDecl (mkModuleName "Prelude")+ prelude = noLocA $ simpleImportDecl (mkModuleName "Prelude") -- Predicate to test for a 'Prelude' import declaration. isPrelude :: LImportDecl GhcPs -> Bool@@ -52,7 +54,7 @@ -- thing. This is the case if the names are equal and (1) denote a -- builtin type or data constructor or (2) the intersection of the -- candidate modules where the two names arise is non-empty.-scopeMatch :: (Scope, Located RdrName) -> (Scope, Located RdrName) -> Bool+scopeMatch :: (Scope, LocatedN RdrName) -> (Scope, LocatedN RdrName) -> Bool scopeMatch (a, x) (b, y) | isSpecial x && isSpecial y = rdrNameStr x == rdrNameStr y | isSpecial x || isSpecial y = False@@ -62,48 +64,63 @@ -- Given a name in a scope, and a new scope, create a name for the new -- scope that will refer to the same thing. If the resulting name is -- ambiguous, pick a plausible candidate.-scopeMove :: (Scope, Located RdrName) -> Scope -> Located RdrName+scopeMove :: (Scope, LocatedN RdrName) -> Scope -> LocatedN RdrName scopeMove (a, x@(fromQual -> Just name)) (Scope b) = case imps of- [] -> headDef x real- imp:_ | all (\x -> ideclQualified x /= NotQualified) imps -> noLoc $ mkRdrQual (unLoc . fromMaybe (ideclName imp) $ firstJust ideclAs imps) name+ [] | -- If `possModules a x` includes Prelude, but `b` does not contain any module that may import `x`,+ -- then unqualify `x` and assume that it is from Prelude (#1298).+ any (\(L _ x) -> (moduleNameString . fst <$> isQual_maybe x) == Just "Prelude") real -> unqual x+ | otherwise -> headDef x real+ imp:_ | all (\x -> ideclQualified x /= NotQualified) imps -> noLocA $ mkRdrQual (unLoc . fromMaybe (ideclName imp) $ firstJust ideclAs imps) name | otherwise -> unqual x where- real :: [Located RdrName]- real = [noLoc $ mkRdrQual m name | m <- possModules a x]+ real :: [LocatedN RdrName]+ real = [noLocA $ mkRdrQual m name | m <- possModules a x] imps :: [ImportDecl GhcPs]- imps = [unLoc i | r <- real, i <- b, possImport i r]+ imps = [unLoc i | r <- real, i <- b, possImport i r /= NotImported] scopeMove (_, x) _ = x -- Calculate which modules a name could possibly lie in. If 'x' is -- qualified but no imported element matches it, assume the user just -- lacks an import.-possModules :: Scope -> Located RdrName -> [ModuleName]-possModules (Scope is) x = f x+-- 'prelude' is added to the result, unless we are certain which module a name is from (#1298).+possModules :: Scope -> LocatedN RdrName -> [ModuleName]+possModules (Scope is) x =+ [prelude | prelude `notElem` map fst res, not (any snd res)] ++ fmap fst res where- res :: [ModuleName]- res = [unLoc $ ideclName $ unLoc i | i <- is, possImport i x]+ -- The 'Bool' signals whether we are certain that 'x' is imported from the module.+ res0, res :: [(ModuleName, Bool)]+ res0 = [ (unLoc $ ideclName $ unLoc i, isImported == Imported)+ | i <- is, let isImported = possImport i x, isImported /= NotImported ] - f :: Located RdrName -> [ModuleName]- f n | isSpecial n = [mkModuleName ""]- f (L _ (Qual mod _)) = [mod | null res] ++ res- f _ = res+ res | isSpecial x = [(mkModuleName "", True)]+ | L _ (Qual mod _) <- x = [(mod, True) | null res0] ++ res0+ | otherwise = res0 + prelude = mkModuleName "Prelude"++data IsImported = Imported | PossiblyImported | NotImported deriving (Eq)+ -- Determine if 'x' could possibly lie in the module named by the -- import declaration 'i'.-possImport :: LImportDecl GhcPs -> Located RdrName -> Bool-possImport i n | isSpecial n = False+possImport :: LImportDecl GhcPs -> LocatedN RdrName -> IsImported+possImport i n | isSpecial n = NotImported possImport (L _ i) (L _ (Qual mod x)) =- mod `elem` ms && possImport (noLoc i{ideclQualified=NotQualified}) (noLoc $ mkRdrUnqual x)+ if mod `elem` ms && NotImported /= possImport (noLocA i{ideclQualified=NotQualified}) (noLocA $ mkRdrUnqual x)+ then Imported+ else NotImported where ms = map unLoc $ ideclName i : maybeToList (ideclAs i)-possImport (L _ i) (L _ (Unqual x)) = ideclQualified i == NotQualified && maybe True f (ideclHiding i)+possImport (L _ i) (L _ (Unqual x)) =+ if ideclQualified i == NotQualified+ then maybe PossiblyImported f (ideclHiding i)+ else NotImported where- f :: (Bool, Located [LIE GhcPs]) -> Bool- f (hide, L _ xs) =- if hide then- Just True `notElem` ms- else- Nothing `elem` ms || Just True `elem` ms+ f :: (Bool, LocatedL [LIE GhcPs]) -> IsImported+ f (hide, L _ xs)+ | hide = if Just True `elem` ms then NotImported else PossiblyImported+ | Just True `elem` ms = Imported+ | Nothing `elem` ms = PossiblyImported+ | otherwise = NotImported where ms = map g xs tag :: String@@ -113,9 +130,9 @@ g (L _ (IEVar _ y)) = Just $ tag == unwrapName y g (L _ (IEThingAbs _ y)) = Just $ tag == unwrapName y g (L _ (IEThingAll _ y)) = if tag == unwrapName y then Just True else Nothing- g (L _ (IEThingWith _ y _wildcard ys _fields)) = Just $ tag `elem` unwrapName y : map unwrapName ys+ g (L _ (IEThingWith _ y _wildcard ys)) = Just $ tag `elem` unwrapName y : map unwrapName ys g _ = Just False unwrapName :: LIEWrappedName RdrName -> String unwrapName x = occNameString (rdrNameOcc $ ieWrappedName (unLoc x))-possImport _ _ = False+possImport _ _ = NotImported
src/GHC/Util/SrcLoc.hs view
@@ -1,21 +1,33 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Util.SrcLoc (- stripLocs+ getAncLoc+ , stripLocs , SrcSpanD(..) ) where +import GHC.Parser.Annotation import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Data.FastString import 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)) Nothing+ -- 'stripLocs x' is 'x' with all contained source locs replaced by -- 'noSrcSpan'. stripLocs :: Data from => from -> from-stripLocs = transformBi (const noSrcSpan)+stripLocs =+ transformBi (const dummySpan) . transformBi (const noSrcSpan)+ where+ dummyLoc = mkRealSrcLoc (fsLit "dummy") 1 1+ dummySpan = mkRealSrcSpan dummyLoc dummyLoc -- TODO (2020-10-03, SF): Maybe move the following definitions down to -- ghc-lib-parser at some point.@@ -38,7 +50,7 @@ _ -> EQ -- error "'Duplicate.hs' invariant error: can't compare unhelpful spans" _ -> EQ -- error "'Duplicate.hs' invariant error: can't compare unhelpful spans" compareRealSrcSpans a b =- let (a1, a2, a3, a4, a5) = (srcSpanFile a, srcSpanStartLine a, srcSpanStartCol a, srcSpanEndLine a, srcSpanEndCol a)- (b1, b2, b3, b4, b5) = (srcSpanFile b, srcSpanStartLine b, srcSpanStartCol b, srcSpanEndLine b, srcSpanEndCol b)+ let (a1, a2, a3, a4, a5) = (LexicalFastString (srcSpanFile a), srcSpanStartLine a, srcSpanStartCol a, srcSpanEndLine a, srcSpanEndCol a)+ (b1, b2, b3, b4, b5) = (LexicalFastString (srcSpanFile b), srcSpanStartLine b, srcSpanStartCol b, srcSpanEndLine b, srcSpanEndCol b) in compare (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5) instance Ord SrcSpanD where compare = compareSrcSpans
src/GHC/Util/Unify.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-} module GHC.Util.Unify(- Subst, fromSubst,+ Subst(..), fromSubst, validSubst, removeParens, substitute, unifyExp ) where@@ -77,13 +77,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 noExtField lhs y rhs))+ | Just y <- lookup (rdrNameStr x) bind = Just (L loc (OpApp EpAnnNotUsed lhs y rhs)) -- Left sections. exp (L loc (SectionL _ exp (L _ (HsVar _ x))))- | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionL noExtField exp y))+ | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionL EpAnnNotUsed exp y)) -- Right sections. exp (L loc (SectionR _ (L _ (HsVar _ x)) exp))- | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionR noExtField y exp))+ | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionR EpAnnNotUsed y exp)) exp _ = Nothing pat :: LPat GhcPs -> LPat GhcPs@@ -102,7 +102,7 @@ --------------------------------------------------------------------- -- UNIFICATION -type NameMatch = Located RdrName -> Located RdrName -> Bool+type NameMatch = LocatedN RdrName -> LocatedN RdrName -> Bool -- | Unification, obeys the property that if @unify a b = s@, then -- @substitute s a = b@.@@ -112,11 +112,39 @@ | Just (x, y) <- cast (x, y) = unifyPat' nm x y | Just (x, y) <- cast (x, y) = unifyType' nm x y | Just (x, y) <- cast (x, y) = if (x :: FastString) == y then Just mempty else Nothing- | Just (x :: SrcSpan) <- cast x = Just mempty++ -- We need some type magic to reduce this.+ | Just (x :: EpAnn 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 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 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+ | Just (x :: EpAnn AnnFieldLabel) <- cast x = Just mempty+ | Just (x :: EpAnn EpAnnSumPat) <- cast x = Just mempty+ | Just (x :: EpAnn AnnSig) <- cast x = Just mempty+ | 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 (y :: SrcSpan) <- cast y = Just mempty+ | otherwise = unifyDef' nm x y unifyDef' :: Data a => NameMatch -> a -> a -> Maybe (Subst (LHsExpr GhcPs))-unifyDef' nm x y = fmap mconcat . sequence =<< gzip (unify' nm False) x y+unifyDef' nm x y =+ fmap mconcat . sequence =<< gzip (unify' nm False) x y unifyComposed' :: NameMatch -> LHsExpr GhcPs@@ -126,7 +154,7 @@ ((, Just y11) <$> unifyExp' nm False x1 y12) <|> case y12 of (L _ (OpApp _ y121 dot' y122)) | isDot dot' ->- unifyComposed' nm x1 (noLoc (OpApp noExtField y11 dot y121)) dot' y122+ unifyComposed' nm x1 (noLocA (OpApp EpAnnNotUsed y11 dot y121)) dot' y122 _ -> Nothing -- unifyExp handles the cases where both x and y are HsApp, or y is OpApp. Otherwise,@@ -160,7 +188,7 @@ -- Attempt #1: rewrite '(fun1 . fun2) arg' as 'fun1 (fun2 arg)', and unify it with 'x'. -- The guard ensures that you don't get duplicate matches because the matching engine -- auto-generates hints in dot-form.- (, Nothing) <$> unifyExp' nm root x (noLoc (HsApp noExtField y11 (noLoc (HsApp noExtField y12 y2))))+ (, Nothing) <$> unifyExp' nm root x (noLocA (HsApp EpAnnNotUsed y11 (noLocA (HsApp EpAnnNotUsed 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',@@ -175,9 +203,9 @@ unifyExp nm root x (L _ (OpApp _ lhs2 op2@(L _ (HsVar _ op2')) rhs2)) | (L _ (OpApp _ lhs1 op1@(L _ (HsVar _ op1')) rhs1)) <- x = guard (nm op1' op2') >> (, Nothing) <$> liftA2 (<>) (unifyExp' nm False lhs1 lhs2) (unifyExp' nm False rhs1 rhs2)- | isDol op2 = unifyExp nm root x $ noLoc (HsApp noExtField lhs2 rhs2)- | isAmp op2 = unifyExp nm root x $ noLoc (HsApp noExtField rhs2 lhs2)- | otherwise = unifyExp nm root x $ noLoc (HsApp noExtField (noLoc (HsApp noExtField op2 (addPar lhs2))) (addPar rhs2))+ | isDol op2 = unifyExp nm root x $ noLocA (HsApp 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)) where -- add parens around when desugaring the expression, if necessary addPar :: LHsExpr GhcPs -> LHsExpr GhcPs@@ -229,8 +257,8 @@ unifyExp' nm root x y@(L _ (OpApp _ lhs2 op2@(L _ (HsVar _ op2')) rhs2)) = noExtra $ unifyExp nm root x y -unifyExp' nm root (L _ (HsBracket _ (VarBr _ b0 (occNameStr -> v1))))- (L _ (HsBracket _ (VarBr _ b1 (occNameStr -> v2))))+unifyExp' nm root (L _ (HsBracket _ (VarBr _ b0 (occNameStr . unLoc -> v1))))+ (L _ (HsBracket _ (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@@ -260,6 +288,6 @@ unifyType' nm (L loc (HsTyVar _ _ x)) y = let wc = HsWC noExtField y :: LHsWcType (NoGhcTc GhcPs) unused = strToVar "__unused__" :: LHsExpr GhcPs- appType = L loc (HsAppType noExtField unused wc) :: LHsExpr GhcPs+ appType = L loc (HsAppType noSrcSpan unused wc) :: LHsExpr GhcPs in Just $ Subst [(rdrNameStr x, appType)] unifyType' nm x y = unifyDef' nm x y
src/GHC/Util/View.hs view
@@ -14,52 +14,52 @@ import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import GHC.Util.Brackets -fromParen :: LHsExpr GhcPs -> LHsExpr GhcPs+fromParen :: LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs) fromParen x = maybe x fromParen $ remParen x -fromPParen :: LPat GhcPs -> LPat GhcPs+fromPParen :: LocatedA (Pat GhcPs) -> LocatedA (Pat GhcPs) fromPParen (L _ (ParPat _ x)) = fromPParen x fromPParen x = x class View a b where view :: a -> b -data RdrName_ = NoRdrName_ | RdrName_ (Located RdrName)+data RdrName_ = NoRdrName_ | RdrName_ (LocatedN RdrName) data Var_ = NoVar_ | Var_ String deriving Eq data PVar_ = NoPVar_ | PVar_ String-data PApp_ = NoPApp_ | PApp_ String [LPat GhcPs]-data App2 = NoApp2 | App2 (LHsExpr GhcPs) (LHsExpr GhcPs) (LHsExpr GhcPs)-data LamConst1 = NoLamConst1 | LamConst1 (LHsExpr GhcPs)+data PApp_ = NoPApp_ | PApp_ String [LocatedA (Pat GhcPs)]+data App2 = NoApp2 | App2 (LocatedA (HsExpr GhcPs)) (LocatedA (HsExpr GhcPs)) (LocatedA (HsExpr GhcPs))+data LamConst1 = NoLamConst1 | LamConst1 (LocatedA (HsExpr GhcPs)) -instance View (LHsExpr GhcPs) LamConst1 where+instance View (LocatedA (HsExpr GhcPs)) LamConst1 where view (fromParen -> (L _ (HsLam _ (MG _ (L _ [L _ (Match _ LambdaExpr [L _ WildPat {}]- (GRHSs _ [L _ (GRHS _ [] x)] (L _ (EmptyLocalBinds _))))]) FromSource)))) = LamConst1 x+ (GRHSs _ [L _ (GRHS _ [] x)] ((EmptyLocalBinds _))))]) FromSource)))) = LamConst1 x view _ = NoLamConst1 -instance View (LHsExpr GhcPs) RdrName_ where+instance View (LocatedA (HsExpr GhcPs)) RdrName_ where view (fromParen -> (L _ (HsVar _ name))) = RdrName_ name view _ = NoRdrName_ -instance View (LHsExpr GhcPs) Var_ where+instance View (LocatedA (HsExpr GhcPs)) Var_ where view (view -> RdrName_ name) = Var_ (rdrNameStr name) view _ = NoVar_ -instance View (LHsExpr GhcPs) App2 where+instance View (LocatedA (HsExpr GhcPs)) App2 where view (fromParen -> L _ (OpApp _ lhs op rhs)) = App2 op lhs rhs view (fromParen -> L _ (HsApp _ (L _ (HsApp _ f x)) y)) = App2 f x y view _ = NoApp2 -instance View (Located (Pat GhcPs)) PVar_ where+instance View (LocatedA (Pat GhcPs)) PVar_ where view (fromPParen -> L _ (VarPat _ (L _ x))) = PVar_ $ occNameStr x view _ = NoPVar_ -instance View (Located (Pat GhcPs)) PApp_ where- view (fromPParen -> L _ (ConPat _ (L _ x) (PrefixCon args))) =+instance View (LocatedA (Pat GhcPs)) PApp_ where+ view (fromPParen -> L _ (ConPat _ (L _ x) (PrefixCon _ args))) = PApp_ (occNameStr x) args view (fromPParen -> L _ (ConPat _ (L _ x) (InfixCon lhs rhs))) = PApp_ (occNameStr x) [lhs, rhs] view _ = NoPApp_ -- A lambda with no guards and no where clauses-pattern SimpleLambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs-pattern SimpleLambda vs body <- L _ (HsLam _ (MG _ (L _ [L _ (Match _ _ vs (GRHSs _ [L _ (GRHS _ [] body)] (L _ (EmptyLocalBinds _))))]) _))+pattern SimpleLambda :: [LocatedA (Pat GhcPs)] -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)+pattern SimpleLambda vs body <- L _ (HsLam _ (MG _ (L _ [L _ (Match _ _ vs (GRHSs _ [L _ (GRHS _ [] body)] ((EmptyLocalBinds _))))]) _))
src/Hint/All.hs view
@@ -49,7 +49,6 @@ builtin :: HintBuiltin -> Hint builtin x = case x of- -- Ghc. HintLambda -> decl lambdaHint HintImport -> modu importHint HintExport -> modu exportHint
src/Hint/Bracket.hs view
@@ -110,7 +110,7 @@ module Hint.Bracket(bracketHint) where -import Hint.Type(DeclHint,Idea(..),rawIdea,warn,suggest,Severity(..),toRefactSrcSpan,toSS)+import Hint.Type(DeclHint,Idea(..),rawIdea,warn,suggest,Severity(..),toRefactSrcSpan,toSSA) import Data.Data import Data.List.Extra import Data.Generics.Uniplate.DataOnly@@ -122,6 +122,7 @@ import GHC.Util import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import Language.Haskell.GhclibParserEx.GHC.Hs.Pat bracketHint :: DeclHint bracketHint _ _ x =@@ -150,13 +151,13 @@ -- latter (in contrast to the HSE pretty printer). This patches things -- up. prettyExpr :: LHsExpr GhcPs -> String-prettyExpr s@(L _ SectionL{}) = unsafePrettyPrint (noLoc (HsPar noExtField s) :: LHsExpr GhcPs)-prettyExpr s@(L _ SectionR{}) = unsafePrettyPrint (noLoc (HsPar noExtField s) :: LHsExpr GhcPs)+prettyExpr s@(L _ SectionL{}) = unsafePrettyPrint (noLocA (HsPar EpAnnNotUsed s) :: LHsExpr GhcPs)+prettyExpr s@(L _ SectionR{}) = unsafePrettyPrint (noLocA (HsPar EpAnnNotUsed s) :: LHsExpr GhcPs) prettyExpr x = unsafePrettyPrint x -- 'Just _' if at least one set of parens were removed. 'Nothing' if -- zero parens were removed.-remParens' :: Brackets (Located a) => Located a -> Maybe (Located a)+remParens' :: Brackets (LocatedA a) => LocatedA a -> Maybe (LocatedA a) remParens' = fmap go . remParen where go e = maybe e go (remParen e)@@ -169,14 +170,14 @@ isPartialAtom (Just (L _ HsSpliceE{})) _ = True isPartialAtom _ x = isRecConstr x || isRecUpdate x -bracket :: forall a . (Data a, Outputable a, Brackets (Located a)) => (Located a -> String) -> (Maybe (Located a) -> Located a -> Bool) -> Bool -> Located a -> [Idea]+bracket :: forall a . (Data a, Outputable a, Brackets (LocatedA a)) => (LocatedA a -> String) -> (Maybe (LocatedA a) -> LocatedA a -> Bool) -> Bool -> LocatedA a -> [Idea] bracket pretty isPartialAtom root = f Nothing where msg = "Redundant bracket" -- 'f' is a (generic) function over types in 'Brackets -- (expressions, patterns and types). Arguments are, 'f (Maybe -- (index, parent, gen)) child'.- f :: (Data a, Outputable a, Brackets (Located a)) => Maybe (Int, Located a , Located a -> Located a) -> Located a -> [Idea]+ f :: (Data a, Outputable a, Brackets (LocatedA a)) => Maybe (Int, LocatedA a , LocatedA a -> LocatedA a) -> LocatedA a -> [Idea] -- No context. Removing parentheses from 'x' succeeds? f Nothing o@(remParens' -> Just x) -- If at the root, or 'x' is an atom, 'x' parens are redundant.@@ -195,39 +196,34 @@ | not $ needBracket i o x , not $ isPartialAtom (Just o) x , not $ any isSplicePat $ universeBi o -- over-appoximate ,see #1292- = rawIdea Suggestion msg (getLoc v) (pretty o) (Just (pretty (gen x))) [] [r] : g x+ = rawIdea Suggestion msg (getLocA v) (pretty o) (Just (pretty (gen x))) [] [r] : g x where typ = findType v- r = Replace typ (toSS v) [("x", toSS x)] "x"+ r = Replace typ (toSSA v) [("x", toSSA x)] "x" -- Regardless of the context, there are no parentheses to remove -- from 'x'. f _ x = g x - g :: (Data a, Outputable a, Brackets (Located a)) => Located a -> [Idea]+ g :: (Data a, Outputable a, Brackets (LocatedA a)) => LocatedA a -> [Idea] -- Enumerate over all the immediate children of 'o' looking for -- redundant parentheses in each. g o = concat [f (Just (i, o, gen)) x | (i, (x, gen)) <- zipFrom 0 $ holes o] -isSplicePat :: Pat GhcPs -> Bool-isSplicePat SplicePat{} = True-isSplicePat _ = False--bracketWarning :: (Outputable a, Outputable b, Brackets (Located b)) => String -> Located a -> Located b -> Idea bracketWarning msg o x =- suggest msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"]+ suggest msg (reLoc o) (reLoc x) [Replace (findType x) (toSSA o) [("x", toSSA x)] "x"] -bracketError :: (Outputable a, Outputable b, Brackets (Located b)) => String -> Located a -> Located b -> Idea+bracketError :: (Outputable a, Outputable b, Brackets (LocatedA b)) => String -> LocatedA a -> LocatedA b -> Idea bracketError msg o x =- warn msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"]+ warn msg (reLoc o) (reLoc x) [Replace (findType x) (toSSA o) [("x", toSSA x)] "x"] fieldDecl :: LConDeclField GhcPs -> [Idea] fieldDecl o@(L loc f@ConDeclField{cd_fld_type=v@(L l (HsParTy _ c))}) = let r = L loc (f{cd_fld_type=c}) :: LConDeclField GhcPs in- [rawIdea Suggestion "Redundant bracket" l+ [rawIdea Suggestion "Redundant bracket" (locA l) (showSDocUnsafe $ ppr_fld o) -- Note this custom printer! (Just (showSDocUnsafe $ ppr_fld r)) []- [Replace Type (toSS v) [("x", toSS c)] "x"]]+ [Replace Type (toSSA v) [("x", toSSA c)] "x"]] where -- If we call 'unsafePrettyPrint' on a field decl, we won't like -- the output (e.g. "[foo, bar] :: T"). Here we use a custom@@ -246,33 +242,33 @@ dollar :: LHsExpr GhcPs -> [Idea] dollar = concatMap f . universe where- f x = [ (suggest "Redundant $" x y [r]){ideaSpan = getLoc d} | L _ (OpApp _ a d b) <- [x], isDol d- , let y = noLoc (HsApp noExtField a b) :: LHsExpr GhcPs+ f x = [ (suggest "Redundant $" (reLoc x) (reLoc y) [r]){ideaSpan = locA (getLoc d)} | L _ (OpApp _ a d b) <- [x], isDol d+ , let y = noLocA (HsApp EpAnnNotUsed a b) :: LHsExpr GhcPs , not $ needBracket 0 y a , not $ needBracket 1 y b , not $ isPartialAtom (Just x) b- , let r = Replace Expr (toSS x) [("a", toSS a), ("b", toSS b)] "a b"]+ , let r = Replace Expr (toSSA x) [("a", toSSA a), ("b", toSSA b)] "a b"] ++- [ suggest "Move brackets to avoid $" x (t y) [r]+ [ suggest "Move brackets to avoid $" (reLoc x) (reLoc (t y)) [r] |(t, e@(L _ (HsPar _ (L _ (OpApp _ a1 op1 a2))))) <- splitInfix x , isDol op1 , isVar a1 || isApp a1 || isPar a1, not $ isAtom a2 , varToStr a1 /= "select" -- special case for esqueleto, see #224- , let y = noLoc $ HsApp noExtField a1 (noLoc (HsPar noExtField a2))- , let r = Replace Expr (toSS e) [("a", toSS a1), ("b", toSS a2)] "a (b)" ]+ , let y = noLocA $ HsApp EpAnnNotUsed a1 (noLocA (HsPar EpAnnNotUsed a2))+ , let r = Replace Expr (toSSA e) [("a", toSSA a1), ("b", toSSA a2)] "a (b)" ] ++ -- Special case of (v1 . v2) <$> v3- [ (suggest "Redundant bracket" x y [r]){ideaSpan = locPar}+ [ (suggest "Redundant bracket" (reLoc x) (reLoc y) [r]){ideaSpan = locA locPar} | L _ (OpApp _ (L locPar (HsPar _ o1@(L locNoPar (OpApp _ _ (isDot -> True) _)))) o2 v3) <- [x], varToStr o2 == "<$>"- , let y = noLoc (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs- , let r = Replace Expr (toRefactSrcSpan locPar) [("a", toRefactSrcSpan locNoPar)] "a"]+ , let y = noLocA (OpApp EpAnnNotUsed o1 o2 v3) :: LHsExpr GhcPs+ , let r = Replace Expr (toRefactSrcSpan (locA locPar)) [("a", toRefactSrcSpan (locA locNoPar))] "a"] ++- [ suggest "Redundant section" x y [r]+ [ suggest "Redundant section" (reLoc x) (reLoc y) [r] | L _ (HsApp _ (L _ (HsPar _ (L _ (SectionL _ a b)))) c) <- [x] -- , error $ show (unsafePrettyPrint a, gshow b, unsafePrettyPrint c)- , let y = noLoc $ OpApp noExtField a b c :: LHsExpr GhcPs- , let r = Replace Expr (toSS x) [("x", toSS a), ("op", toSS b), ("y", toSS c)] "x op y"]+ , let y = noLocA $ OpApp EpAnnNotUsed 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 noExtField lhs op, rhs), (\lhs -> L l (OpApp noExtField lhs op rhs), lhs)]+ [(L l . OpApp EpAnnNotUsed lhs op, rhs), (\lhs -> L l (OpApp EpAnnNotUsed lhs op rhs), lhs)] splitInfix _ = []
src/Hint/Comment.hs view
@@ -31,7 +31,7 @@ commentHint :: ModuHint commentHint _ m = concatMap chk (ghcComments m) where- chk :: Located AnnotationComment -> [Idea]+ chk :: LEpaComment -> [Idea] chk comm | isMultiline, "#" `isSuffixOf` s && not ("#" `isPrefixOf` s) = [grab "Fix pragma markup" comm $ '#':s] | isMultiline, name `elem` directives = [grab "Use pragma syntax" comm $ "# " ++ trim s ++ " #"]@@ -41,9 +41,11 @@ name = takeWhile (\x -> isAlphaNum x || x == '_') $ trimStart s chk _ = [] - grab :: String -> Located AnnotationComment -> String -> Idea+ grab :: String -> LEpaComment -> String -> Idea grab msg o@(L pos _) s2 =- let s1 = commentText o in- rawIdea Suggestion msg pos (f s1) (Just $ f s2) [] refact+ let s1 = commentText o+ loc = RealSrcSpan (anchor pos) Nothing+ in+ rawIdea Suggestion msg loc (f s1) (Just $ f s2) [] (refact loc) where f s = if isCommentMultiline o then "{-" ++ s ++ "-}" else "--" ++ s- refact = [ModifyComment (toRefactSrcSpan pos) (f s2)]+ refact loc = [ModifyComment (toRefactSrcSpan loc) (f s2)]
src/Hint/Duplicate.hs view
@@ -57,10 +57,10 @@ ] where ds = [(modName m, fromMaybe "" (declName d), unLoc d)- | ModuleEx m _ <- map snd ms+ | ModuleEx m <- map snd ms , d <- hsmodDecls (unLoc m)] -dupes :: (Outputable e, Data e) => [(String, String, [Located e])] -> [Idea]+dupes :: (Outputable e, Data e) => [(String, String, [LocatedA e])] -> [Idea] dupes ys = [(rawIdeaN (if length xs >= 5 then Hint.Type.Warning else Suggestion)@@ -72,7 +72,7 @@ | ((m1, d1, SrcSpanD p1), (m2, d2, SrcSpanD p2), xs) <- duplicateOrdered 3 $ map f ys] where f (m, d, xs) =- [((m, d, SrcSpanD (getLoc x)), extendInstances (stripLocs x)) | x <- xs]+ [((m, d, SrcSpanD (locA (getLoc x))), extendInstances (stripLocs x)) | x <- xs] --------------------------------------------------------------------- -- DUPLICATE FINDING
src/Hint/Export.hs view
@@ -22,9 +22,9 @@ import GHC.Types.Name.Reader exportHint :: ModuHint-exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) _)+exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) ) | Nothing <- exports =- let r = o{ hsmodExports = Just (noLoc [noLoc (IEModuleContents noExtField name)] )} in+ let r = o{ hsmodExports = Just (noLocA [noLocA (IEModuleContents EpAnnNotUsed 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,7 +33,7 @@ , exports' <- [x | x <- xs, not (matchesModName modName x)] , modName `elem` names = let dots = mkRdrUnqual (mkVarOcc " ... ")- r = o{ hsmodExports = Just (noLoc (noLoc (IEVar noExtField (noLoc (IEName (noLoc dots)))) : exports') )}+ r = o{ hsmodExports = Just (noLocA (noLocA (IEVar noExtField (noLocA (IEName (noLocA dots)))) : exports') )} in [ignore "Use explicit module export list" (L s o) (noLoc r) []] where
src/Hint/Extensions.hs view
@@ -124,6 +124,8 @@ foo = id -- {-# LANGUAGE TypeApplications #-} \ foo = id @Int+{-# LANGUAGE TypeApplications #-} \+x :: Typeable b => TypeRep @Bool b {-# LANGUAGE LambdaCase #-} \ foo = id -- {-# LANGUAGE LambdaCase #-} \@@ -232,13 +234,23 @@ data T m a = MkT (m a) (T Maybe (m a)) {-# LANGUAGE NoMonomorphismRestriction, NamedFieldPuns #-} \ main = 1 -- @Note Extension NamedFieldPuns is not used+{-# LANGUAGE FunctionalDependencies #-} \+class HasField x r a | x r -> a+{-# LANGUAGE OverloadedRecordDot #-} \+f x = x.foo+{-# LANGUAGE OverloadedRecordDot #-} \+f x = x . foo -- @NoRefactor: refactor requires GHC >= 9.2.1+{-# LANGUAGE OverloadedRecordDot #-} \+f = (.foo)+{-# LANGUAGE OverloadedRecordDot #-} \+f = (. foo) -- @NoRefactor: refactor requires GHC >= 9.2.1 </TEST> -} module Hint.Extensions(extensionsHint) where -import Hint.Type(ModuHint,rawIdea,Severity(Warning),Note(..),toSS,ghcAnnotations,ghcModule)+import Hint.Type(ModuHint,rawIdea,Severity(Warning),Note(..),toSSAnc,ghcModule,modComments) import Extension import Data.Generics.Uniplate.DataOnly@@ -251,9 +263,9 @@ import qualified Data.Map as Map import GHC.Types.SrcLoc+import GHC.Types.SourceText import GHC.Hs import GHC.Types.Basic-import GHC.Core.Class import GHC.Types.Name.Reader import GHC.Types.ForeignCall @@ -262,7 +274,7 @@ import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr-import Language.Haskell.GhclibParserEx.GHC.Hs.Types+import Language.Haskell.GhclibParserEx.GHC.Hs.Type import Language.Haskell.GhclibParserEx.GHC.Hs.Decls import Language.Haskell.GhclibParserEx.GHC.Hs.Binds import Language.Haskell.GhclibParserEx.GHC.Hs.ImpExp@@ -272,15 +284,16 @@ extensionsHint :: ModuHint extensionsHint _ x =- [ rawIdea Hint.Type.Warning "Unused LANGUAGE pragma"- sl- (comment (mkLanguagePragmas sl exts))+ [+ rawIdea Hint.Type.Warning "Unused LANGUAGE pragma"+ (RealSrcSpan (anchor sl) Nothing)+ (comment_ (mkLanguagePragmas sl exts)) (Just newPragma) ( [RequiresExtension (show gone) | (_, Just x) <- before \\ after, gone <- Map.findWithDefault [] x disappear] ++ [ Note $ "Extension " ++ s ++ " is " ++ reason x | (s, Just x) <- explainedRemovals])- [ModifyComment (toSS (mkLanguagePragmas sl exts)) newPragma]- | (L sl _, exts) <- languagePragmas $ pragmas (ghcAnnotations x)+ [ModifyComment (toSSAnc (mkLanguagePragmas sl exts)) newPragma]+ | (L sl _, exts) <- languagePragmas $ pragmas (modComments x) , let before = [(x, readExtension x) | x <- exts] , let after = filter (maybe True (`Set.member` keep) . snd) before , before /= after@@ -288,7 +301,7 @@ | null after && not (any (`Map.member` implied) $ mapMaybe snd before) = [] | otherwise = before \\ after , let newPragma =- if null after then "" else comment (mkLanguagePragmas sl $ map fst after)+ if null after then "" else comment_ (mkLanguagePragmas sl $ map fst after) ] where usedTH :: Bool@@ -301,7 +314,7 @@ -- All the extensions defined to be used. extensions :: Set.Set Extension extensions = Set.fromList $ mapMaybe readExtension $- concatMap snd $ languagePragmas (pragmas (ghcAnnotations x))+ concatMap snd $ languagePragmas (pragmas (modComments x)) -- Those extensions we detect to be useful. useful :: Set.Set Extension@@ -366,13 +379,18 @@ 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 ParallelListComp = hasS isParComp-used FunctionalDependencies = hasT (un :: FunDep (Located RdrName))+used FunctionalDependencies = hasT (un :: FunDep GhcPs) used ImplicitParams = hasT (un :: HsIPName)-used TypeApplications = hasS isTypeApp+used TypeApplications = hasS isTypeApp ||^ hasS isKindTyApp used EmptyDataDecls = hasS f where f :: HsDataDefn GhcPs -> Bool@@ -447,7 +465,7 @@ where f :: OverLitVal -> Bool f (HsIntegral (IL (SourceText t) _ _)) = '_' `elem` t- f (HsFractional (FL (SourceText t) _ _)) = '_' `elem` t+ f (HsFractional (FL (SourceText t) _ _ _ _)) = '_' `elem` t f _ = False used LambdaCase = hasS isLCase@@ -480,6 +498,7 @@ used PatternSynonyms = hasS isPatSynBind ||^ hasS isPatSynIE used ImportQualifiedPost = hasS (== QualifiedPost) used StandaloneKindSignatures = hasT (un :: StandaloneKindSig GhcPs)+used OverloadedRecordDot = hasS isGetField ||^ hasS isProjection used _= const True @@ -502,10 +521,10 @@ addDerives :: Maybe NewOrData -> Maybe (DerivStrategy GhcPs) -> [String] -> Derives addDerives _ (Just s) xs = case s of- StockStrategy -> mempty{derivesStock' = xs}- AnyclassStrategy -> mempty{derivesAnyclass = xs}- NewtypeStrategy -> mempty{derivesNewtype' = xs}- ViaStrategy{} -> mempty+ StockStrategy {} -> mempty{derivesStock' = xs}+ AnyclassStrategy {} -> mempty{derivesAnyclass = xs}+ NewtypeStrategy {} -> mempty{derivesNewtype' = xs}+ ViaStrategy {} -> mempty addDerives nt _ xs = mempty {derivesStock' = stock ,derivesAnyclass = other@@ -516,18 +535,20 @@ derives (L _ m) = mconcat $ map decl (childrenBi m) ++ map idecl (childrenBi m) where idecl :: DataFamInstDecl GhcPs -> Derives- idecl (DataFamInstDecl (HsIB _ FamEqn {feqn_rhs=HsDataDefn {dd_ND=dn, dd_derivs=(L _ ds)}})) = g dn ds+ idecl (DataFamInstDecl FamEqn {feqn_rhs=HsDataDefn {dd_ND=dn, dd_derivs=ds}}) = g dn ds decl :: LHsDecl GhcPs -> Derives- decl (L _ (TyClD _ (DataDecl _ _ _ _ HsDataDefn {dd_ND=dn, dd_derivs=(L _ ds)}))) = g dn ds -- Data declaration.+ decl (L _ (TyClD _ (DataDecl _ _ _ _ HsDataDefn {dd_ND=dn, dd_derivs=ds}))) = g dn ds -- Data declaration. decl (L _ (DerivD _ (DerivDecl _ (HsWC _ sig) strategy _))) = addDerives Nothing (fmap unLoc strategy) [derivedToStr sig] -- A deriving declaration. decl _ = mempty g :: NewOrData -> [LHsDerivingClause GhcPs] -> Derives- g dn ds = mconcat [addDerives (Just dn) (fmap unLoc strategy) $ map derivedToStr tys | L _ (HsDerivingClause _ strategy (L _ tys)) <- ds]+ g dn ds = mconcat+ ([addDerives (Just dn) (fmap unLoc strategy) $ map derivedToStr tys | L _ (HsDerivingClause _ strategy (L _ (DctMulti _ tys))) <- ds] +++ [addDerives (Just dn) (fmap unLoc strategy) $ map derivedToStr [ty] | L _ (HsDerivingClause _ strategy (L _ (DctSingle _ ty))) <- ds]) derivedToStr :: LHsSigType GhcPs -> String- derivedToStr (HsIB _ t) = ih t+ derivedToStr (L _ (HsSig _ _ t)) = ih t where ih :: LHsType GhcPs -> String ih (L _ (HsQualTy _ _ a)) = ih a
src/Hint/Fixities.hs view
@@ -16,7 +16,7 @@ module Hint.Fixities(fixitiesHint) where -import Hint.Type(DeclHint,Idea(..),rawIdea,toSS)+import Hint.Type(DeclHint,Idea(..),rawIdea,toSSA) import Config.Type import Control.Monad import Data.List.Extra@@ -24,7 +24,7 @@ import Data.Generics.Uniplate.DataOnly import Refact.Types -import GHC.Types.Basic (compareFixity)+import GHC.Types.Fixity(compareFixity) import Fixity import GHC.Hs import GHC.Util@@ -51,8 +51,8 @@ Just x <- [remParen v] guard $ redundantInfixBracket fixities i o x pure $- rawIdea Ignore msg (getLoc v) (unsafePrettyPrint o)- (Just (unsafePrettyPrint (gen x))) [] [Replace (findType v) (toSS v) [("x", toSS x)] "x"]+ rawIdea Ignore msg (locA (getLoc v)) (unsafePrettyPrint o)+ (Just (unsafePrettyPrint (gen x))) [] [Replace (findType v) (toSSA v) [("x", toSSA x)] "x"] redundantInfixBracket :: Map String Fixity -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool redundantInfixBracket fixities i parent child
src/Hint/Import.hs view
@@ -37,7 +37,7 @@ module Hint.Import(importHint) where -import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),suggest,toSS,rawIdea)+import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),suggest,toSSA,rawIdea) import Refact.Types hiding (ModuleName) import qualified Refact.Types as R import Data.Tuple.Extra@@ -48,14 +48,13 @@ import Prelude import GHC.Data.FastString-import GHC.Types.Basic+import GHC.Types.SourceText import GHC.Hs import GHC.Types.SrcLoc import GHC.Unit.Types -- for 'NotBoot' import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable - importHint :: ModuHint importHint _ ModuleEx {ghcModule=L _ HsModule{hsmodImports=ms}} = -- Ideas for combining multiple imports.@@ -71,7 +70,7 @@ reduceImports :: [LImportDecl GhcPs] -> [Idea] reduceImports [] = [] reduceImports ms@(m:_) =- [rawIdea Hint.Type.Warning "Use fewer imports" (getLoc m) (f ms) (Just $ f x) [] rs+ [rawIdea Hint.Type.Warning "Use fewer imports" (locA (getLoc m)) (f ms) (Just $ f x) [] rs | Just (x, rs) <- [simplify ms]] where f = unlines . map unsafePrettyPrint @@ -97,29 +96,29 @@ -> Maybe (LImportDecl GhcPs, [Refactoring R.SrcSpan]) combine x@(L loc x') y@(L _ y') -- Both (un/)qualified, common 'as', same names : Delete the second.- | qual, as, specs = Just (x, [Delete Import (toSS y)])+ | qual, as, specs = Just (x, [Delete Import (toSSA y)]) -- Both (un/)qualified, common 'as', different names : Merge the -- second into the first and delete it. | qual, as , Just (False, xs) <- ideclHiding x' , Just (False, ys) <- ideclHiding y' =- let newImp = L loc x'{ideclHiding = Just (False, noLoc (unLoc xs ++ unLoc ys))}- in Just (newImp, [Replace Import (toSS x) [] (unsafePrettyPrint (unLoc newImp))- , Delete Import (toSS y)])+ let newImp = L loc x'{ideclHiding = Just (False, noLocA (unLoc xs ++ unLoc ys))}+ in Just (newImp, [Replace Import (toSSA x) [] (unsafePrettyPrint (unLoc newImp))+ , Delete Import (toSSA y)]) -- Both (un/qualified), common 'as', one has names the other doesn't -- : Delete the one with names. | qual, as, isNothing (ideclHiding x') || isNothing (ideclHiding y') = let (newImp, toDelete) = if isNothing (ideclHiding x') then (x, y) else (y, x)- in Just (newImp, [Delete Import (toSS toDelete)])+ in Just (newImp, [Delete Import (toSSA toDelete)]) -- Both unqualified, same names, one (and only one) has an 'as' -- clause : Delete the one without an 'as'. | ideclQualified x' == NotQualified, qual, specs, length ass == 1 = let (newImp, toDelete) = if isJust (ideclAs x') then (x, y) else (y, x)- in Just (newImp, [Delete Import (toSS toDelete)])+ in Just (newImp, [Delete Import (toSSA toDelete)]) -- No hints. | otherwise = Nothing where- eqMaybe:: Eq a => Maybe (Located a) -> Maybe (Located a) -> Bool+ eqMaybe:: Eq a => Maybe (LocatedA a) -> Maybe (LocatedA a) -> Bool eqMaybe (Just x) (Just y) = x `eqLocated` y eqMaybe Nothing Nothing = True eqMaybe _ _ = False@@ -131,8 +130,8 @@ transformBi (const noSrcSpan) (ideclHiding y') stripRedundantAlias :: LImportDecl GhcPs -> [Idea]-stripRedundantAlias x@(L loc i@ImportDecl {..})+stripRedundantAlias x@(L _ i@ImportDecl {..}) -- Suggest 'import M as M' be just 'import M'. | Just (unLoc ideclName) == fmap unLoc ideclAs =- [suggest "Redundant as" x (L loc i{ideclAs=Nothing} :: LImportDecl GhcPs) [RemoveAsKeyword (toSS x)]]+ [suggest "Redundant as" (reLoc x) (noLoc i{ideclAs=Nothing} :: Located (ImportDecl GhcPs)) [RemoveAsKeyword (toSSA x)]] stripRedundantAlias _ = []
src/Hint/Lambda.hs view
@@ -37,7 +37,6 @@ f = foo (\y -> g x . h $ y) -- g x . h f = foo (\y -> g x . h $ y) -- @Message Avoid lambda f = foo ((*) x) -- (x *)-f = foo ((Prelude.*) x) -- (x Prelude.*) f = (*) x f = foo (flip op x) -- (`op` x) f = foo (flip op x) -- @Message Use section@@ -107,7 +106,7 @@ module Hint.Lambda(lambdaHint) where -import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, suggestN, ideaNote, substVars, toRefactSrcSpan)+import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, toSSA, suggestN, ideaNote, substVars, toRefactSrcSpan) import Util import Data.List.Extra import Data.Set (Set)@@ -116,6 +115,7 @@ import Data.Generics.Uniplate.DataOnly (universe, universeBi, transformBi) import GHC.Types.Basic+import GHC.Types.Fixity import GHC.Hs import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader@@ -147,18 +147,18 @@ 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 _ (EmptyLocalBinds _) <- bind+ | EmptyLocalBinds _ <- bind , isLambda $ fromParen origBody , null (universeBi pats :: [HsExpr GhcPs]) = let (newPats, newBody) = fromLambda . lambda pats $ origBody (sub, tpl) = mkSubtsAndTpl newPats newBody- gen :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs+ gen :: [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs) gen ps = uncurry reform . fromLambda . lambda ps refacts = case newBody of -- https://github.com/alanz/ghc-exactprint/issues/97 L _ HsCase{} -> []- _ -> [Replace rtype (toSS o) sub tpl]- in [warn "Redundant lambda" o (gen pats origBody) refacts]+ _ -> [Replace rtype (toSSA o) sub tpl]+ in [warn "Redundant lambda" (reLoc o) (gen pats origBody) refacts] | let (newPats, newBody) = etaReduce pats origBody , length newPats < length pats, pvars (drop (length newPats) pats) `disjoint` varss bind@@ -166,15 +166,15 @@ in [warn "Eta reduce" (reform pats origBody) (reform newPats newBody) [Replace rtype (toSS $ reform pats origBody) sub tpl] ]- where reform :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs- reform ps b = L (combineSrcSpans loc1 loc2) $ ValD noExtField $- origBind- {fun_matches = MG noExtField (noLoc [noLoc $ Match noExtField ctxt ps $ GRHSs noExtField [noLoc $ GRHS noExtField [] b] $ noLoc $ EmptyLocalBinds noExtField]) Generated}+ where+ reform :: [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)+ reform ps b = L (combineSrcSpans (locA loc1) (locA loc2)) $ ValD noExtField $+ origBind {fun_matches = MG noExtField (noLocA [noLocA $ Match EpAnnNotUsed ctxt ps $ GRHSs emptyComments [noLoc $ GRHS EpAnnNotUsed [] b] $ EmptyLocalBinds noExtField]) Generated} mkSubtsAndTpl newPats newBody = (sub, tpl) where (origPats, vars) = mkOrigPats (Just (rdrNameStr funName)) newPats- sub = ("body", toSS newBody) : zip vars (map toSS newPats)+ sub = ("body", toSSA newBody) : zip vars (map toSSA newPats) tpl = unsafePrettyPrint (reform origPats varBody) lambdaBind _ _ = []@@ -185,7 +185,7 @@ , y `notElem` vars x , not $ any isQuasiQuote $ universe x = etaReduce ps x-etaReduce ps (L loc (OpApp _ x (isDol -> True) y)) = etaReduce ps (L loc (HsApp noExtField x y))+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]@@ -194,23 +194,24 @@ , isAtom y , allowLeftSection $ occNameString f , not $ isTypeApp y- = [suggest "Use section" o to [r]]+ = [suggest "Use section" (reLoc o) (reLoc to) [r]] where to :: LHsExpr GhcPs- to = noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField y oper- r = Replace Expr (toSS o) [("x", toSS y)] ("(x " ++ unsafePrettyPrint origf ++ ")")+ to = noLocA $ HsPar EpAnnNotUsed $ 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))) | allowRightSection (rdrNameStr f), not $ "(" `isPrefixOf` rdrNameStr f- = [suggest "Use section" o to [r]]+ = [suggest "Use section" (reLoc o) (reLoc to) [r]] where to :: LHsExpr GhcPs- to = noLoc $ HsPar noExtField $ noLoc $ SectionR noExtField origf y+ to = noLocA $ HsPar EpAnnNotUsed $ noLocA $ SectionR EpAnnNotUsed origf y op = if isSymbolRdrName (unLoc f) then unsafePrettyPrint f else "`" ++ unsafePrettyPrint f ++ "`" var = if rdrNameStr f == "x" then "y" else "x"- r = Replace Expr (toSS o) [(var, toSS y)] ("(" ++ op ++ " " ++ var ++ ")")+ r = Replace Expr (toSSA o) [(var, toSSA y)] ("(" ++ op ++ " " ++ var ++ ")")+ lambdaExp p o@(L _ HsLam{}) | not $ any isOpApp p , (res, refact) <- niceLambdaR [] o@@ -225,7 +226,7 @@ | L _ HsPar{} <- res -> p | L _ (HsVar _ (L _ name)) <- res, not (isSymbolRdrName name) -> p _ -> o- = [(if isVar res then warn else suggest) name from res (refact $ toSS from)]+ = [(if isVar res then warn else suggest) name (reLoc from) (reLoc res) (refact $ toSSA from)] where countRightSections :: LHsExpr GhcPs -> Int countRightSections x = length [() | L _ (SectionR _ (view -> Var_ _) _) <- universe x]@@ -234,11 +235,11 @@ | isLambda (fromParen origBody) , null (universeBi origPats :: [HsExpr GhcPs]) -- TODO: I think this checks for view patterns only, so maybe be more explicit about that? , maybe True (not . isLambda) p =- [suggest "Collapse lambdas" o (lambda pats body) [Replace Expr (toSS o) subts template]]+ [suggest "Collapse lambdas" (reLoc o) (reLoc (lambda pats body)) [Replace Expr (toSSA o) subts template]] where (pats, body) = fromLambda o (oPats, vars) = mkOrigPats Nothing pats- subts = ("body", toSS body) : zip vars (map toSS pats)+ subts = ("body", toSSA body) : zip vars (map toSSA pats) template = unsafePrettyPrint (lambda oPats varBody) -- match a lambda with a variable pattern, with no guards and no where clauses@@ -250,9 +251,8 @@ | ([_x], ys) <- partition ((==Just x) . tupArgVar) args -- the other arguments must not have a nested x somewhere in them , Set.notMember x $ Set.map occNameString $ freeVars ys- -> [(suggestN "Use tuple-section" o $ noLoc $ ExplicitTuple noExtField (map removeX args) boxity)+ -> [(suggestN "Use tuple-section" (reLoc o) $ noLoc $ ExplicitTuple EpAnnNotUsed (map removeX args) boxity) {ideaNote = [RequiresExtension "TupleSections"]}]- -- suggest @LambdaCase@/directly matching in a lambda instead of doing @\x -> case x of ...@ HsCase _ (view -> Var_ x') matchGroup -- is the case being done on the variable from our original lambda?@@ -267,46 +267,46 @@ -- * mark match as being in a lambda context so that it's printed properly oldMG@(MG _ (L _ [L _ oldmatch]) _) | all (\(L _ (GRHS _ stmts _)) -> null stmts) (grhssGRHSs (m_grhss oldmatch)) ->- let patLocs = fmap getLoc (m_pats oldmatch)- bodyLocs = concatMap (\case L _ (GRHS _ _ body) -> [getLoc body])+ let patLocs = fmap (locA . getLoc) (m_pats oldmatch)+ bodyLocs = concatMap (\case L _ (GRHS _ _ body) -> [locA (getLoc body)]) $ grhssGRHSs (m_grhss oldmatch) r | notNull patLocs && notNull bodyLocs = let xloc = foldl1' combineSrcSpans patLocs yloc = foldl1' combineSrcSpans bodyLocs- in [ Replace Expr (toSS o) [("x", toRefactSrcSpan xloc), ("y", toRefactSrcSpan yloc)]+ in [ Replace Expr (toSSA o) [("x", toRefactSrcSpan xloc), ("y", toRefactSrcSpan yloc)] ((if needParens then "\\(x)" else "\\x") ++ " -> y") ] | otherwise = [] needParens = any (patNeedsParens appPrec . unLoc) (m_pats oldmatch)- in [ suggest "Use lambda" o+ in [ suggest "Use lambda" (reLoc o) ( noLoc $ HsLam noExtField oldMG- { mg_alts = noLoc- [ noLoc oldmatch+ { mg_alts = noLocA+ [ noLocA oldmatch { m_pats = map mkParPat $ m_pats oldmatch , m_ctxt = LambdaExpr } ] }- :: LHsExpr GhcPs+ :: Located (HsExpr GhcPs) ) r ] -- otherwise we should use @LambdaCase@ MG _ (L _ _) _ ->- [(suggestN "Use lambda-case" o $ noLoc $ HsLamCase noExtField matchGroup)+ [(suggestN "Use lambda-case" (reLoc o) $ noLoc $ HsLamCase EpAnnNotUsed matchGroup) {ideaNote=[RequiresExtension "LambdaCase"]}] _ -> [] where -- | Filter out tuple arguments, converting the @x@ (matched in the lambda) variable argument -- to a missing argument, so that we get the proper section.- removeX :: LHsTupArg GhcPs -> LHsTupArg GhcPs- removeX (L _ (Present _ (view -> Var_ x')))- | x == x' = noLoc $ Missing noExtField+ removeX :: HsTupArg GhcPs -> HsTupArg GhcPs+ removeX (Present _ (view -> Var_ x'))+ | x == x' = Missing EpAnnNotUsed removeX y = y -- | Extract the name of an argument of a tuple if it's present and a variable.- tupArgVar :: LHsTupArg GhcPs -> Maybe String- tupArgVar (L _ (Present _ (view -> Var_ x))) = Just x+ tupArgVar :: HsTupArg GhcPs -> Maybe String+ tupArgVar (Present _ (view -> Var_ x)) = Just x tupArgVar _ = Nothing lambdaExp _ _ = []@@ -350,4 +350,4 @@ -- Replace the pattern with a variable pattern if the pattern doesn't contain wildcards. munge :: String -> (Bool, LPat GhcPs) -> LPat GhcPs munge _ (True, p) = p- munge ident (False, L ploc _) = L ploc (VarPat noExtField (L ploc $ mkRdrUnqual $ mkVarOcc ident))+ munge ident (False, L ploc _) = L ploc (VarPat noExtField (noLocA $ mkRdrUnqual $ mkVarOcc ident))
src/Hint/List.hs view
@@ -47,7 +47,7 @@ import Data.Maybe import Prelude -import Hint.Type(DeclHint,Idea,suggest,ignore,substVars,toRefactSrcSpan,toSS,ghcAnnotations)+import Hint.Type(DeclHint,Idea,suggest,ignore,substVars,toRefactSrcSpan,toSSA,modComments) import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R@@ -55,6 +55,7 @@ import GHC.Hs import GHC.Types.SrcLoc import GHC.Types.Basic+import GHC.Types.SourceText import GHC.Types.Name.Reader import GHC.Data.FastString import GHC.Builtin.Types@@ -62,7 +63,7 @@ import GHC.Util import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr-import Language.Haskell.GhclibParserEx.GHC.Hs.Types+import Language.Haskell.GhclibParserEx.GHC.Hs.Type import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader@@ -71,7 +72,7 @@ listHint :: DeclHint listHint _ modu = listDecl overloadedListsOn where- exts = concatMap snd (languagePragmas (pragmas (ghcAnnotations modu)))+ exts = concatMap snd (languagePragmas (pragmas (modComments modu))) overloadedListsOn = "OverloadedLists" `elem` exts listDecl :: Bool -> LHsDecl GhcPs -> [Idea]@@ -89,7 +90,6 @@ listCompCheckGuards o ListComp stmts listComp o@(L _ (HsDo _ MonadComp (L _ stmts))) = listCompCheckGuards o MonadComp stmts- listComp (L _ HsPar{}) = [] -- App2 "sees through" paren, which causes duplicate hints with universeBi listComp o@(view -> App2 mp f (L _ (HsDo _ ListComp (L _ stmts)))) = listCompCheckMap o mp f ListComp stmts@@ -105,15 +105,15 @@ list_comp_aux e xs where list_comp_aux e xs- | "False" `elem` cons = [suggest "Short-circuited list comprehension" o o' (suggestExpr o o')]- | "True" `elem` cons = [suggest "Redundant True guards" o o2 (suggestExpr o o2)]- | not (astListEq xs ys) = [suggest "Move guards forward" o o3 (suggestExpr o o3)]+ | "False" `elem` cons = [suggest "Short-circuited list comprehension" (reLoc o) (reLoc o') (suggestExpr o o')]+ | "True" `elem` cons = [suggest "Redundant True guards" (reLoc o) (reLoc o2) (suggestExpr o o2)]+ | not (astListEq xs ys) = [suggest "Move guards forward" (reLoc o) (reLoc o3) (suggestExpr o o3)] | otherwise = [] where ys = moveGuardsForward xs- o' = noLoc $ ExplicitList noExtField Nothing []- o2 = noLoc $ HsDo noExtField ctx (noLoc (filter ((/= Just "True") . qualCon) xs ++ [e]))- o3 = noLoc $ HsDo noExtField ctx (noLoc $ ys ++ [e])+ o' = noLocA $ ExplicitList EpAnnNotUsed []+ o2 = noLocA $ HsDo EpAnnNotUsed ctx (noLocA (filter ((/= Just "True") . qualCon) xs ++ [e]))+ o3 = noLocA $ HsDo EpAnnNotUsed ctx (noLocA $ ys ++ [e]) cons = mapMaybe qualCon xs qualCon :: ExprLStmt GhcPs -> Maybe String qualCon (L _ (BodyStmt _ (L _ (HsVar _ (L _ x))) _ _)) = Just (occNameStr x)@@ -122,16 +122,16 @@ listCompCheckMap :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> [Idea] listCompCheckMap o mp f ctx stmts | varToStr mp == "map" =- [suggest "Move map inside list comprehension" o o2 (suggestExpr o o2)]+ [suggest "Move map inside list comprehension" (reLoc o) (reLoc o2) (suggestExpr o o2)] where revs = reverse stmts L _ (LastStmt _ body b s) = head revs -- In a ListComp, this is always last.- last = noLoc $ LastStmt noExtField (noLoc $ HsApp noExtField (paren f) (paren body)) b s- o2 =noLoc $ HsDo noExtField ctx (noLoc $ reverse (tail revs) ++ [last])+ last = noLocA $ LastStmt noExtField (noLocA $ HsApp EpAnnNotUsed (paren f) (paren body)) b s+ o2 =noLocA $ HsDo EpAnnNotUsed ctx (noLocA $ reverse (tail revs) ++ [last]) listCompCheckMap _ _ _ _ _ = [] suggestExpr :: LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring R.SrcSpan]-suggestExpr o o2 = [Replace Expr (toSS o) [] (unsafePrettyPrint o2)]+suggestExpr o o2 = [Replace Expr (toSSA o) [] (unsafePrettyPrint o2)] moveGuardsForward :: [ExprLStmt GhcPs] -> [ExprLStmt GhcPs] moveGuardsForward = reverse . f [] . reverse@@ -160,17 +160,18 @@ then concatMap (listExp overloadedListsOn $ isAppend x) $ children x else [head res] where- res = [suggest name x x2 [r]+ res = [suggest name (reLoc x) (reLoc x2) [r] | (name, f) <- checks overloadedListsOn , Just (x2, subts, temp) <- [f b x]- , let r = Replace Expr (toSS x) subts temp ]+ , let r = Replace Expr (toSSA x) subts temp ] listPat :: LPat GhcPs -> [Idea] listPat x = if null res then concatMap listPat $ children x else [head res]- where res = [suggest name x x2 [r]+ where res = [suggest name (reLoc x) (reLoc x2) [r] | (name, f) <- pchecks , Just (x2, subts, temp) <- [f x]- , let r = Replace Pattern (toSS x) subts temp ]+ , let r = Replace Pattern (toSSA x) subts temp ]+ isAppend :: View a App2 => a -> Bool isAppend (view -> App2 op _ _) = varToStr op == "++" isAppend _ = False@@ -190,16 +191,16 @@ usePString :: LPat GhcPs -> Maybe (LPat GhcPs, [a], String) usePString (L _ (ListPat _ xs)) | not $ null xs, Just s <- mapM fromPChar xs =- let literal = noLoc $ LitPat noExtField (HsString NoSourceText (fsLit (show s)))+ let literal = noLocA $ LitPat noExtField (HsString NoSourceText (fsLit (show s))) :: LPat GhcPs in Just (literal, [], unsafePrettyPrint literal) usePString _ = Nothing usePList :: LPat GhcPs -> Maybe (LPat GhcPs, [(String, R.SrcSpan)], String) usePList = fmap ( (\(e, s) ->- (noLoc (ListPat noExtField e)+ (noLocA (ListPat EpAnnNotUsed e) , map (fmap toRefactSrcSpan . fst) s- , unsafePrettyPrint (noLoc $ ListPat noExtField (map snd s) :: LPat GhcPs))+ , unsafePrettyPrint (noLocA $ ListPat EpAnnNotUsed (map snd s) :: LPat GhcPs)) ) . unzip )@@ -210,20 +211,20 @@ f first _ _ = Nothing g :: String -> LPat GhcPs -> ((String, SrcSpan), LPat GhcPs)- g s (getLoc -> loc) = ((s, loc), noLoc $ VarPat noExtField (noLoc $ mkVarUnqual (fsLit s)))+ g s (locA . getLoc -> loc) = ((s, loc), noLocA $ VarPat noExtField (noLocA $ mkVarUnqual (fsLit s))) useString :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [a], String)-useString b (L _ (ExplicitList _ _ xs)) | not $ null xs, Just s <- mapM fromChar xs =- let literal = noLoc (HsLit noExtField (HsString NoSourceText (fsLit (show s))))+useString b (L _ (ExplicitList _ xs)) | not $ null xs, Just s <- mapM fromChar xs =+ let literal = noLocA (HsLit EpAnnNotUsed (HsString NoSourceText (fsLit (show s)))) :: LHsExpr GhcPs in Just (literal, [], unsafePrettyPrint literal) useString _ _ = Nothing useList :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String) useList b = fmap ( (\(e, s) ->- (noLoc (ExplicitList noExtField Nothing e)- , map (fmap toSS) s- , unsafePrettyPrint (noLoc $ ExplicitList noExtField Nothing (map snd s) :: LHsExpr GhcPs))+ (noLocA (ExplicitList EpAnnNotUsed e)+ , map (fmap toSSA) s+ , unsafePrettyPrint (noLocA $ ExplicitList EpAnnNotUsed (map snd s) :: LHsExpr GhcPs)) ) . unzip )@@ -242,28 +243,28 @@ , Just (newX, tplX, spanX) <- f x , not $ isAppend y = Just (gen newX y- , [("x", spanX), ("xs", toSS y)]+ , [("x", spanX), ("xs", toSSA y)] , unsafePrettyPrint $ gen tplX (strToVar "xs") ) where f :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, LHsExpr GhcPs, R.SrcSpan)- f (L _ (ExplicitList _ _ [x]))- | isAtom x || isApp x = Just (x, strToVar "x", toSS x)- | otherwise = Just (addParen x, addParen (strToVar "x"), toSS x)+ f (L _ (ExplicitList _ [x]))+ | isAtom x || isApp x = Just (x, strToVar "x", toSSA x)+ | otherwise = Just (addParen x, addParen (strToVar "x"), toSSA x) f _ = Nothing gen :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs- gen x = noLoc . OpApp noExtField x (noLoc (HsVar noExtField (noLoc consDataCon_RDR)))+ gen x = noLocA . OpApp EpAnnNotUsed x (noLocA (HsVar noExtField (noLocA consDataCon_RDR))) useCons _ _ = Nothing typeListChar :: LHsType GhcPs typeListChar =- noLoc $ HsListTy noExtField- (noLoc (HsTyVar noExtField NotPromoted (noLoc (mkVarUnqual (fsLit "Char")))))+ noLocA $ HsListTy EpAnnNotUsed+ (noLocA (HsTyVar EpAnnNotUsed NotPromoted (noLocA (mkVarUnqual (fsLit "Char"))))) typeString :: LHsType GhcPs typeString =- noLoc $ HsTyVar noExtField NotPromoted (noLoc (mkVarUnqual (fsLit "String")))+ noLocA $ HsTyVar EpAnnNotUsed NotPromoted (noLocA (mkVarUnqual (fsLit "String"))) stringType :: LHsDecl GhcPs -> [Idea] stringType (L _ x) = case x of@@ -276,7 +277,7 @@ f x = concatMap g $ childrenBi x g :: LHsType GhcPs -> [Idea]- g e@(fromTyParen -> x) = [ignore "Use String" x (transform f x)+ g e@(fromTyParen -> x) = [ignore "Use String" (reLoc x) (reLoc (transform f x)) rs | not . null $ rs] where f x = if astEq x typeListChar then typeString else x- rs = [Replace Type (toSS t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq t typeListChar]+ rs = [Replace Type (toSSA t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq t typeListChar]
src/Hint/ListRec.hs view
@@ -31,7 +31,7 @@ module Hint.ListRec(listRecHint) where -import Hint.Type (DeclHint, Severity(Suggestion, Warning), idea, toSS)+import Hint.Type (DeclHint, Severity(Suggestion, Warning), idea, toSSA) import Data.Generics.Uniplate.DataOnly import Data.List.Extra@@ -51,6 +51,9 @@ import GHC.Hs.Decls import GHC.Types.Basic +import GHC.Parser.Annotation+import Language.Haskell.Syntax.Extension+ import GHC.Util import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr@@ -69,7 +72,7 @@ guard $ recursiveStr `notElem` varss y -- Maybe we can do better here maintaining source -- formatting?- pure $ idea severity ("Use " ++ use) o y [Replace Decl (toSS o) [] (unsafePrettyPrint y)]+ pure $ idea severity ("Use " ++ use) (reLoc o) (reLoc y) [Replace Decl (toSSA o) [] (unsafePrettyPrint y)] recursiveStr :: String recursiveStr = "_recursive_"@@ -93,7 +96,6 @@ Int -- list position BList (LHsExpr GhcPs) -- list type/body - --------------------------------------------------------------------- -- MATCH THE RECURSION @@ -139,12 +141,12 @@ , m_pats=[v@(L _ VarPat{})] , m_grhss=GRHSs _ [L _ (GRHS _ [] rhs)]- (L _ (EmptyLocalBinds _))}]}))+ (EmptyLocalBinds _)}]})) ) =- [ noLoc $ BindStmt noExtField v lhs- , noLoc $ BodyStmt noExtField rhs noSyntaxExpr noSyntaxExpr ]+ [ noLocA $ BindStmt EpAnnNotUsed v lhs+ , noLocA $ BodyStmt noExtField rhs noSyntaxExpr noSyntaxExpr ] asDo (L _ (HsDo _ (DoExpr _) (L _ stmts))) = stmts-asDo x = [noLoc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr]+asDo x = [noLocA $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr] ---------------------------------------------------------------------@@ -170,14 +172,14 @@ (ps, b2) <- pure $ eliminateArgs ps1 b2 let ps12 = let (a, b) = splitAt p1 ps1 in map strToPat (a ++ xs : b) -- Function arguments.- emptyLocalBinds = noLoc $ EmptyLocalBinds noExtField -- Empty where clause.- gRHS e = noLoc $ GRHS noExtField [] e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs.- gRHSSs e = GRHSs noExtField [gRHS e] emptyLocalBinds -- Guarded rhs set.- match e = Match{m_ext=noExtField,m_pats=ps12, m_grhss=gRHSSs e, ..} -- Match.- matchGroup e = MG{mg_alts=noLoc [noLoc $ match e], mg_origin=Generated, ..} -- Match group.+ emptyLocalBinds = EmptyLocalBinds noExtField :: HsLocalBindsLR GhcPs GhcPs -- Empty where clause.+ gRHS e = noLoc $ 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. funBind e = FunBind {fun_matches=matchGroup e, ..} :: HsBindLR GhcPs GhcPs -- Fun bind. - pure (ListCase ps b1 (x, xs, b2), noLoc . ValD noExtField . funBind)+ pure (ListCase ps b1 (x, xs, b2), noLocA . ValD noExtField . funBind) delCons :: String -> Int -> String -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs) delCons func pos var (fromApps -> (view -> Var_ x) : xs) | func == x = do@@ -207,7 +209,7 @@ , m_pats = ps , m_grhss = GRHSs {grhssGRHSs=[L l (GRHS _ [] body)]- , grhssLocalBinds=L _ (EmptyLocalBinds _)+ , grhssLocalBinds=EmptyLocalBinds _ } } <- pure x (a, b, c) <- findPat ps@@ -225,6 +227,6 @@ readPat (view -> PVar_ x) = Just $ Left x readPat (L _ (ParPat _ (L _ (ConPat _ (L _ n) (InfixCon (view -> PVar_ x) (view -> PVar_ xs)))))) | n == consDataCon_RDR = Just $ Right $ BCons x xs-readPat (L _ (ConPat _ (L _ n) (PrefixCon [])))+readPat (L _ (ConPat _ (L _ n) (PrefixCon [] []))) | n == nameRdrName nilDataConName = Just $ Right BNil readPat _ = Nothing
src/Hint/Match.hs view
@@ -39,10 +39,7 @@ module Hint.Match(readMatch) where -import Hint.Type (ModuleEx,Idea,idea,ideaNote,toSS)---- import Language.Haskell.GhclibParserEx.Dump--- import GHC.Utils.Outputable+import Hint.Type (ModuleEx,Idea,idea,ideaNote,toSSA) import Util import Timing@@ -58,7 +55,7 @@ import GHC.Data.Bag import GHC.Hs import GHC.Types.SrcLoc-import GHC.Types.Basic+import GHC.Types.SourceText import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence import Data.Data@@ -67,7 +64,6 @@ import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader--- import Debug.Trace readMatch :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea] readMatch settings = findIdeas (concatMap readRule settings)@@ -104,8 +100,8 @@ -- If a == b then -- x is 'a', op is '==' and y is 'b' and,- let lSec = addParen (L l (SectionL noExtField x op)) -- (a == )- rSec = addParen (L l (SectionR noExtField op y)) -- ( == b)+ let lSec = addParen (L l (SectionL EpAnnNotUsed x op)) -- (a == )+ rSec = addParen (L l (SectionR EpAnnNotUsed op y)) -- ( == b) in (first (lSec :) <$> dotVersion y) ++ (first (rSec :) <$> dotVersion x) -- [([(a ==)], b), ([(b == )], a])]. dotVersion _ = [] @@ -114,11 +110,11 @@ findIdeas :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea] findIdeas matches s _ decl = timed "Hint" "Match apply" $ forceList- [ (idea (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes}+ [ (idea (hintRuleSeverity m) (hintRuleName m) (reLoc x) (reLoc y) [r]){ideaNote=notes} | (name, expr) <- findDecls decl , (parent,x) <- universeParentExp expr , m <- matches, Just (y, tpl, notes, subst) <- [matchIdea s name m parent x]- , let r = R.Replace R.Expr (toSS x) subst (unsafePrettyPrint tpl)+ , let r = R.Replace R.Expr (toSSA x) subst (unsafePrettyPrint tpl) ] -- | A list of root expressions, with their associated names@@ -139,12 +135,13 @@ rhs = unextendInstances hintRuleRHS sa = hintRuleScope nm a b = scopeMatch (sa, a) (sb, b)+ (u, extra) <- unifyExp nm True lhs x u <- validSubst astEq u -- Need to check free vars before unqualification, but after subst -- (with 'e') need to unqualify before substitution (with 'res').- let rhs' | Just fun <- extra = rebracket1 $ noLoc (HsApp noExtField fun rhs)+ let rhs' | Just fun <- extra = rebracket1 $ noLocA (HsApp EpAnnNotUsed fun rhs) | otherwise = rhs (e, (tpl, substNoParens)) = substitute u rhs' noParens = [varToStr $ fromParen x | L _ (HsApp _ (varToStr -> "_noParen_") x) <- universe tpl]@@ -164,11 +161,11 @@ guard $ checkSide (unextendInstances <$> hintRuleSide) $ ("original", x) : ("result", res) : fromSubst u guard $ checkDefine declName parent rhs - (u, tpl) <- pure $ if any ((== noSrcSpan) . getLoc . snd) (fromSubst u) then (mempty, res) else (u, tpl)- tpl <- pure $ unqualify sa sb (performSpecial tpl)+ (u, tpl) <- pure $ if any ((== noSrcSpan) . locA . getLoc . snd) (fromSubst u) then (mempty, res) else (u, tpl)+ tpl <- pure $ unqualify sa sb (addBracket parent $ performSpecial tpl) pure ( res, tpl, hintRuleNotes,- [ (s, toSS pos') | (s, pos) <- fromSubst u, getLoc pos /= noSrcSpan+ [ (s, toSSA pos') | (s, pos) <- fromSubst u, locA (getLoc pos) /= noSrcSpan , let pos' = if s `elem` substNoParens then fromParen pos else pos ] )@@ -229,7 +226,7 @@ asInt _ = Nothing list :: LHsExpr GhcPs -> [LHsExpr GhcPs]- list (L _ (ExplicitList _ _ xs)) = xs+ list (L _ (ExplicitList _ xs)) = xs list x = [x] sub :: LHsExpr GhcPs -> LHsExpr GhcPs@@ -240,10 +237,10 @@ -- Does the result look very much like the declaration? checkDefine :: String -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool checkDefine declName Nothing y =- let funOrOp expr = case expr of+ let funOrOp expr = (case expr of L _ (HsApp _ fun _) -> funOrOp fun L _ (OpApp _ _ op _) -> funOrOp op- other -> other+ other -> other) :: LHsExpr GhcPs in declName /= varToStr (transformBi unqual $ funOrOp y) checkDefine _ _ _ = True @@ -262,12 +259,12 @@ unqualify :: Scope -> Scope -> LHsExpr GhcPs -> LHsExpr GhcPs unqualify from to = transformBi f where- f :: Located RdrName -> Located RdrName+ f :: LocatedN RdrName -> LocatedN RdrName f x@(L _ (Unqual s)) | isUnifyVar (occNameString s) = x f x = scopeMove (from, x) to addBracket :: Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs-addBracket (Just (i, p)) c | needBracketOld i p c = noLoc $ HsPar noExtField c+addBracket (Just (i, p)) c | needBracketOld i p c = noLocA $ HsPar EpAnnNotUsed c addBracket _ x = x -- Type substitution e.g. 'Foo Int' for 'a' in 'Proxy a' can lead to a@@ -278,5 +275,5 @@ where f :: LHsType GhcPs -> LHsType GhcPs f (L _ (HsAppTy _ t x@(L _ HsAppTy{}))) =- noLoc (HsAppTy noExtField t (noLoc (HsParTy noExtField x)))+ noLocA (HsAppTy noExtField t (noLocA (HsParTy EpAnnNotUsed x))) f x = x
src/Hint/Monad.hs view
@@ -63,6 +63,7 @@ import Hint.Type import GHC.Hs hiding (Warning)+import GHC.Types.Fixity import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Name.Reader@@ -108,24 +109,24 @@ 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 noExtField op) x- (L l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (L l . OpApp noExtField op dol) x+ (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 loc (HsDo _ ctx (L loc2 [L loc3 (BodyStmt _ y _ _ )]))) -> let doOrMDo = case ctx of MDoExpr _ -> "mdo"; _ -> "do"- in [ ideaRemove Ignore ("Redundant " ++ doOrMDo) (doSpan doOrMDo loc) doOrMDo [Replace Expr (toSS x) [("y", toSS y)] "y"]+ in [ ideaRemove Ignore ("Redundant " ++ doOrMDo) (doSpan doOrMDo (locA loc)) doOrMDo [Replace Expr (toSSA x) [("y", toSSA y)] "y"] | not $ doAsBrackets parentExpr y , not $ doAsAvoidingIndentation parentDo x ] (L loc (HsDo _ (DoExpr mm) (L _ xs))) ->- monadSteps (L loc . HsDo noExtField (DoExpr mm) . noLoc) xs ++- [suggest "Use let" from to [r] | (from, to, r) <- monadLet xs] +++ monadSteps (L loc . HsDo EpAnnNotUsed (DoExpr mm) . noLocA) xs +++ [suggest "Use let" (reLoc from) (reLoc to) [r] | (from, to, r) <- monadLet xs] ++ concat [f x | (L _ (BodyStmt _ x _ _)) <- dropEnd1 xs] ++ concat [f x | (L _ (BindStmt _ (L _ WildPat{}) x)) <- dropEnd1 xs] _ -> [] where f = monadNoResult (fromMaybe "" decl) id seenVoid wrap x = monadNoResult (fromMaybe "" decl) wrap x- ++ [warn "Redundant void" (wrap x) x [Replace Expr (toSS (wrap x)) [("a", toSS x)] "a"] | returnsUnit x]+ ++ [warn "Redundant void" (reLoc (wrap x)) (reLoc x) [Replace Expr (toSSA (wrap x)) [("a", toSSA x)] "a"] | returnsUnit x] doSpan doOrMDo = \case UnhelpfulSpan s -> UnhelpfulSpan s RealSrcSpan s _ ->@@ -147,7 +148,9 @@ -- https://github.com/ndmitchell/hlint/issues/978 -- Return True if they are using do as avoiding identation doAsAvoidingIndentation :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool-doAsAvoidingIndentation (Just (L _ (HsDo _ _ (L (RealSrcSpan a _) _)))) (L _ (HsDo _ _ (L (RealSrcSpan b _) _)))+doAsAvoidingIndentation (Just (L _ (HsDo _ _ (L anna _)))) (L _ (HsDo _ _ (L annb _)))+ | SrcSpanAnn _ (RealSrcSpan a _) <- anna+ , SrcSpanAnn _ (RealSrcSpan b _) <- annb = srcSpanStartCol a == srcSpanStartCol b doAsAvoidingIndentation parent self = False @@ -162,16 +165,15 @@ -- See through HsPar, and down HsIf/HsCase, return the name to use in -- the hint, and the revised expression. monadNoResult :: String -> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]-monadNoResult inside wrap (L l (HsPar _ x)) = monadNoResult inside (wrap . L l . HsPar noExtField) x-monadNoResult inside wrap (L l (HsApp _ x y)) = monadNoResult inside (\x -> wrap $ L l (HsApp noExtField x y)) x+monadNoResult inside wrap (L l (HsPar _ x)) = monadNoResult inside (wrap . L l . HsPar EpAnnNotUsed) 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 noExtField x tag y)) x- | occNameStr op == ">>=" = monadNoResult inside (wrap . L l . OpApp noExtField x tag) 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 monadNoResult inside wrap x | x2 : _ <- filter (`isTag` x) badFuncs , let x3 = x2 ++ "_"-- = [warn ("Use " ++ x3) (wrap x) (wrap $ strToVar x3) [Replace Expr (toSS x) [] x3] | inside /= x3]+ = [warn ("Use " ++ x3) (reLoc (wrap x)) (reLoc (wrap $ strToVar x3)) [Replace Expr (toSSA x) [] x3] | inside /= x3] monadNoResult inside wrap (replaceBranches -> (bs, rewrap)) = map (\x -> x{ideaNote=nubOrd $ Note "May require adding void to other branches" : ideaNote x}) $ concat [monadNoResult inside id b | b <- bs]@@ -181,37 +183,37 @@ -- Rewrite 'do return x; $2' as 'do $2'. monadStep wrap (o@(L _ (BodyStmt _ (fromRet -> Just (ret, _)) _ _ )) : xs@(_:_))- = [ideaRemove Warning ("Redundant " ++ ret) (getLoc o) (unsafePrettyPrint o) [Delete Stmt (toSS o)]]+ = [ideaRemove Warning ("Redundant " ++ ret) (locA (getLoc o)) (unsafePrettyPrint o) [Delete Stmt (toSSA o)]] -- Rewrite 'do a <- $1; return a' as 'do $1'. monadStep wrap o@[ g@(L _ (BindStmt _ (L _ (VarPat _ (L _ p))) x)) , q@(L _ (BodyStmt _ (fromRet -> Just (ret, L _ (HsVar _ (L _ v)))) _ _))] | occNameStr p == occNameStr v- = [warn ("Redundant " ++ ret) (wrap o) (wrap [noLoc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr])- [Replace Stmt (toSS g) [("x", toSS x)] "x", Delete Stmt (toSS q)]]+ = [warn ("Redundant " ++ ret) (reLoc (wrap o)) (reLoc (wrap [noLocA $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr]))+ [Replace Stmt (toSSA g) [("x", toSSA x)] "x", Delete Stmt (toSSA q)]] -- Suggest to use join. Rewrite 'do x <- $1; x; $2' as 'do join $1; $2'. monadStep wrap o@(g@(L _ (BindStmt _ (view -> PVar_ p) x)):q@(L _ (BodyStmt _ (view -> Var_ v) _ _)):xs) | p == v && v `notElem` varss xs- = let app = noLoc $ HsApp noExtField (strToVar "join") x- body = noLoc $ BodyStmt noExtField (rebracket1 app) noSyntaxExpr noSyntaxExpr+ = let app = noLocA $ HsApp EpAnnNotUsed (strToVar "join") x+ body = noLocA $ BodyStmt noExtField (rebracket1 app) noSyntaxExpr noSyntaxExpr stmts = body : xs- in [warn "Use join" (wrap o) (wrap stmts) r]- where r = [Replace Stmt (toSS g) [("x", toSS x)] "join x", Delete Stmt (toSS q)]+ in [warn "Use join" (reLoc (wrap o)) (reLoc (wrap stmts)) r]+ where r = [Replace Stmt (toSSA g) [("x", toSSA x)] "join x", Delete Stmt (toSSA q)] -- Redundant variable capture. Rewrite 'do _ <- <return ()>; $1' as -- 'do <return ()>; $1'. monadStep wrap (o@(L loc (BindStmt _ p x)) : rest) | isPWildcard p, returnsUnit x = let body = L loc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr :: ExprLStmt GhcPs- in [warn "Redundant variable capture" o body [Replace Stmt (toSS o) [("x", toSS x)] "x"]]+ in [warn "Redundant variable capture" (reLoc o) (reLoc body) [Replace Stmt (toSSA o) [("x", toSSA x)] "x"]] -- Redundant unit return : 'do <return ()>; return ()'. monadStep wrap o@[ L _ (BodyStmt _ x _ _) , q@(L _ (BodyStmt _ (fromRet -> Just (ret, L _ (HsVar _ (L _ unit)))) _ _))] | returnsUnit x, occNameStr unit == "()"- = [warn ("Redundant " ++ ret) (wrap o) (wrap $ take 1 o) [Delete Stmt (toSS q)]]+ = [warn ("Redundant " ++ ret) (reLoc (wrap o)) (reLoc (wrap $ take 1 o)) [Delete Stmt (toSSA q)]] -- Rewrite 'do x <- $1; return $ f $ g x' as 'f . g <$> x' monadStep wrap@@ -219,8 +221,8 @@ , q@(L _ (BodyStmt _ (fromApplies -> (ret:f:fs, view -> Var_ v)) _ _))] | isReturn ret, notDol x, u == v, length fs < 3, all isSimple (f : fs), v `notElem` vars (f : fs) =- [warn "Use <$>" (wrap o) (wrap [noLoc $ BodyStmt noExtField (noLoc $ OpApp noExtField (foldl' (\acc e -> noLoc $ OpApp noExtField acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr])- [Replace Stmt (toSS g) (("x", toSS x):zip vs (toSS <$> f:fs)) (intercalate " . " (take (length fs + 1) vs) ++ " <$> x"), Delete Stmt (toSS q)]]+ [warn "Use <$>" (reLoc (wrap o)) (reLoc (wrap [noLocA $ BodyStmt noExtField (noLocA $ OpApp EpAnnNotUsed (foldl' (\acc e -> noLocA $ OpApp EpAnnNotUsed acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr]))+ [Replace Stmt (toSSA g) (("x", toSSA x):zip vs (toSSA <$> f:fs)) (intercalate " . " (take (length fs + 1) vs) ++ " <$> x"), Delete Stmt (toSSA q)]] where isSimple (fromApps -> xs) = all isAtom (x : xs) vs = ('f':) . show <$> [0..]@@ -228,7 +230,6 @@ notDol :: LHsExpr GhcPs -> Bool notDol (L _ (OpApp _ _ op _)) = not $ isDol op notDol _ = True- monadStep _ _ = [] -- Suggest removing a return@@ -247,21 +248,21 @@ | p `notElem` vars y, p `notElem` delete p vs = Just (x, template p y, refact) where- refact = Replace Stmt (toSS x) [("lhs", toSS v), ("rhs", toSS y)]+ refact = Replace Stmt (toSSA x) [("lhs", toSSA v), ("rhs", toSSA y)] (unsafePrettyPrint $ template "lhs" (strToVar "rhs")) mkLet _ = Nothing template :: String -> LHsExpr GhcPs -> ExprLStmt GhcPs template lhs rhs =- let p = noLoc $ mkRdrUnqual (mkVarOcc lhs)- grhs = noLoc (GRHS noExtField [] rhs)- grhss = GRHSs noExtField [grhs] (noLoc (EmptyLocalBinds noExtField))- match = noLoc $ Match noExtField (FunRhs p Prefix NoSrcStrict) [] grhss- fb = noLoc $ FunBind noExtField p (MG noExtField (noLoc [match]) Generated) []+ let p = noLocA $ mkRdrUnqual (mkVarOcc lhs)+ grhs = noLoc (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) [] binds = unitBag fb- valBinds = ValBinds noExtField binds []- localBinds = noLoc $ HsValBinds noExtField valBinds- in noLoc $ LetStmt noExtField localBinds+ valBinds = ValBinds NoAnnSortKey binds []+ localBinds = HsValBinds EpAnnNotUsed valBinds+ in noLocA $ LetStmt EpAnnNotUsed localBinds fromApplies :: LHsExpr GhcPs -> ([LHsExpr GhcPs], LHsExpr GhcPs) fromApplies (L _ (HsApp _ f x)) = first (f:) $ fromApplies (fromParen x)@@ -270,6 +271,6 @@ fromRet :: LHsExpr GhcPs -> Maybe (String, LHsExpr GhcPs) fromRet (L _ (HsPar _ x)) = fromRet x-fromRet (L _ (OpApp _ x (L _ (HsVar _ (L _ y))) z)) | occNameStr y == "$" = fromRet $ noLoc (HsApp noExtField x z)+fromRet (L _ (OpApp _ x (L _ (HsVar _ (L _ y))) z)) | occNameStr y == "$" = fromRet $ noLocA (HsApp EpAnnNotUsed x z) fromRet (L _ (HsApp _ x y)) | isReturn x = Just (unsafePrettyPrint x, y) fromRet _ = Nothing
src/Hint/Naming.hs view
@@ -50,6 +50,7 @@ import qualified Data.Set as Set import GHC.Types.Basic+import GHC.Types.SourceText import GHC.Data.FastString import GHC.Hs.Decls import GHC.Hs.Extension@@ -67,8 +68,8 @@ naming :: Set.Set String -> LHsDecl GhcPs -> [Idea] naming seen originalDecl = [ suggest "Use camelCase"- (shorten originalDecl)- (shorten replacedDecl)+ (reLoc (shorten originalDecl))+ (reLoc (shorten replacedDecl)) [ -- https://github.com/mpickering/apply-refact/issues/39 ] | not $ null suggestedNames@@ -99,7 +100,7 @@ L locGRHS (GRHS ttg0 guards (L locExpr dots)) where dots :: HsExpr GhcPs- dots = HsLit noExtField (HsString (SourceText "...") (mkFastString "..."))+ dots = HsLit EpAnnNotUsed (HsString (SourceText "...") (mkFastString "...")) getNames :: LHsDecl GhcPs -> [String] getNames decl = maybeToList (declName decl) ++ getConstructorNames (unLoc decl)
src/Hint/NewType.hs view
@@ -12,7 +12,7 @@ data Foo = Foo { field1, field2 :: Int} data S a = forall b . Show b => S b {-# LANGUAGE RankNTypes #-}; data S a = forall b . Show b => S b-{-# LANGUAGE RankNTypes #-}; data Foo = Foo (forall a. a) -- newtype Foo = Foo (forall a. a)+{-# LANGUAGE RankNTypes #-}; data Foo = Foo (forall a . a) -- newtype Foo = Foo (forall a. a) data Color a = Red a | Green a | Blue a data Pair a b = Pair a b data Foo = Bar@@ -56,15 +56,15 @@ newtypeHintDecl :: LHsDecl GhcPs -> [Idea] newtypeHintDecl old | Just WarnNewtype{newDecl, insideType} <- singleSimpleField old- = [(suggestN "Use newtype instead of data" old newDecl)+ = [(suggestN "Use newtype instead of data" (reLoc old) (reLoc newDecl)) {ideaNote = [DecreasesLaziness | warnBang insideType]}] newtypeHintDecl _ = [] newTypeDerivingStrategiesHintDecl :: LHsDecl GhcPs -> [Idea] newTypeDerivingStrategiesHintDecl decl@(L _ (TyClD _ (DataDecl _ _ _ _ dataDef))) =- [ignoreNoSuggestion "Use DerivingStrategies" decl | shouldSuggestStrategies dataDef]-newTypeDerivingStrategiesHintDecl decl@(L _ (InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB _ (FamEqn _ _ _ _ _ dataDef)))))) =- [ignoreNoSuggestion "Use DerivingStrategies" decl | shouldSuggestStrategies dataDef]+ [ignoreNoSuggestion "Use DerivingStrategies" (reLoc decl) | shouldSuggestStrategies dataDef]+newTypeDerivingStrategiesHintDecl decl@(L _ (InstD _ (DataFamInstD _ (DataFamInstDecl ((FamEqn _ _ _ _ _ dataDef)))))) =+ [ignoreNoSuggestion "Use DerivingStrategies" (reLoc decl) | shouldSuggestStrategies dataDef] newTypeDerivingStrategiesHintDecl _ = [] -- | Determine if the given data definition should use deriving strategies.@@ -72,7 +72,7 @@ shouldSuggestStrategies dataDef = not (isData dataDef) && not (hasAllStrategies dataDef) hasAllStrategies :: HsDataDefn GhcPs -> Bool-hasAllStrategies (HsDataDefn _ NewType _ _ _ _ (L _ xs)) = all hasStrategyClause xs+hasAllStrategies (HsDataDefn _ NewType _ _ _ _ xs) = all hasStrategyClause xs hasAllStrategies _ = False isData :: HsDataDefn GhcPs -> Bool@@ -105,10 +105,10 @@ }} , insideType = inType }-singleSimpleField (L loc (InstD ext (DataFamInstD instExt (DataFamInstDecl (HsIB hsibExt famEqn@(FamEqn _ _ _ _ _ dataDef))))))+singleSimpleField (L loc (InstD ext (DataFamInstD instExt (DataFamInstDecl famEqn@(FamEqn _ _ _ _ _ dataDef))))) | Just inType <- simpleHsDataDefn dataDef = Just WarnNewtype- { newDecl = L loc $ InstD ext $ DataFamInstD instExt $ DataFamInstDecl $ HsIB hsibExt famEqn {feqn_rhs = dataDef+ { newDecl = L loc $ InstD ext $ DataFamInstD instExt $ DataFamInstDecl $ famEqn {feqn_rhs = dataDef { dd_ND = NewType , dd_cons = dropBangs dataDef }}@@ -128,7 +128,7 @@ -- | Checks whether its argument is a \"simple\" constructor (see criteria in 'singleSimpleField') -- returning the type inside the constructor if it is. This is needed for strictness analysis. simpleCons :: ConDecl GhcPs -> Maybe (HsType GhcPs)-simpleCons (ConDeclH98 _ _ _ [] context (PrefixCon [HsScaled _ (L _ inType)]) _)+simpleCons (ConDeclH98 _ _ _ [] context (PrefixCon [] [HsScaled _ (L _ inType)]) _) | emptyOrNoContext context , not $ isUnboxedTuple inType , not $ isHashy inType@@ -155,10 +155,10 @@ -- | The \"Bang\" here refers to 'HsSrcBang', which notably also includes @UNPACK@ pragmas! dropConsBang :: ConDecl GhcPs -> ConDecl GhcPs -- fields [HsScaled GhcPs (LBangType GhcPs)]-dropConsBang decl@(ConDeclH98 _ _ _ _ _ (PrefixCon fields) _) =+dropConsBang decl@(ConDeclH98 _ _ _ _ _ (PrefixCon [] fields) _) = -- decl {con_args = PrefixCon $ map getBangType fields} let fs' = map (\(HsScaled s lt) -> HsScaled s (getBangType lt)) fields :: [HsScaled GhcPs (LBangType GhcPs)]- in decl {con_args = PrefixCon fs'}+ in decl {con_args = PrefixCon [] fs'} dropConsBang decl@(ConDeclH98 _ _ _ _ _ (RecCon (L recloc conDeclFields)) _) = decl {con_args = RecCon $ L recloc $ removeUnpacksRecords conDeclFields} where
src/Hint/NumLiteral.hs view
@@ -22,36 +22,36 @@ import GHC.Hs import GHC.LanguageExtensions.Type (Extension (..)) import GHC.Types.SrcLoc-import GHC.Types.Basic (SourceText (..), IntegralLit (..), FractionalLit (..))+import GHC.Types.SourceText import GHC.Util.ApiAnnotation (extensions) import Data.Char (isDigit, isOctDigit, isHexDigit) import Data.List (intercalate) import Data.Generics.Uniplate.DataOnly (universeBi) import Refact.Types -import Hint.Type (DeclHint, toSS, ghcAnnotations)+import Hint.Type (DeclHint, toSSA, modComments) import Idea (Idea, suggest) numLiteralHint :: DeclHint numLiteralHint _ modu =- if NumericUnderscores `elem` extensions (ghcAnnotations modu) then+ if NumericUnderscores `elem` extensions (modComments modu) then concatMap suggestUnderscore . universeBi else const [] suggestUnderscore :: LHsExpr GhcPs -> [Idea] suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsIntegral intLit@(IL (SourceText srcTxt) _ _)) _))) =- [ suggest "Use underscore" x y [r] | '_' `notElem` srcTxt, srcTxt /= underscoredSrcTxt ]+ [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` srcTxt, srcTxt /= underscoredSrcTxt ] where underscoredSrcTxt = addUnderscore srcTxt- y = noLoc $ HsOverLit noExtField $ ol{ol_val = HsIntegral intLit{il_text = SourceText underscoredSrcTxt}}- r = Replace Expr (toSS x) [("a", toSS y)] "a"-suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsFractional fracLit@(FL (SourceText srcTxt) _ _)) _))) =- [ suggest "Use underscore" x y [r] | '_' `notElem` srcTxt, srcTxt /= underscoredSrcTxt ]+ 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) _ _ _ _)) _))) =+ [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` srcTxt, srcTxt /= underscoredSrcTxt ] where underscoredSrcTxt = addUnderscore srcTxt- y = noLoc $ HsOverLit noExtField $ ol{ol_val = HsFractional fracLit{fl_text = SourceText underscoredSrcTxt}}- r = Replace Expr (toSS x) [("a", toSS y)] "a"+ y = noLocA $ HsOverLit EpAnnNotUsed $ ol{ol_val = HsFractional fracLit{fl_text = SourceText underscoredSrcTxt}}+ r = Replace Expr (toSSA x) [("a", toSSA y)] "a" suggestUnderscore _ = mempty addUnderscore :: String -> String
src/Hint/Pattern.hs view
@@ -58,7 +58,7 @@ module Hint.Pattern(patternHint) where -import Hint.Type(DeclHint,Idea,ghcAnnotations,ideaTo,toSS,toRefactSrcSpan,suggest,suggestRemove,warn)+import Hint.Type(DeclHint,Idea,modComments,ideaTo,toSSA,toRefactSrcSpan,suggest,suggestRemove,warn) import Data.Generics.Uniplate.DataOnly import Data.Function import Data.List.Extra@@ -90,11 +90,11 @@ concatMap (patHint strict True) (universeBi $ transformBi noPatBind x) ++ concatMap expHint (universeBi x) where- exts = nubOrd $ concatMap snd (languagePragmas (pragmas (ghcAnnotations modu))) -- language extensions enabled at source+ exts = nubOrd $ concatMap snd (languagePragmas (pragmas (modComments modu))) -- language extensions enabled at source strict = "Strict" `elem` exts noPatBind :: LHsBind GhcPs -> LHsBind GhcPs- noPatBind (L loc a@PatBind{}) = L loc a{pat_lhs=noLoc (WildPat noExtField)}+ noPatBind (L loc a@PatBind{}) = L loc a{pat_lhs=noLocA (WildPat noExtField)} noPatBind x = x {-@@ -111,13 +111,13 @@ hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea] hints gen (Pattern l rtype pat (GRHSs _ [L _ (GRHS _ [] bod)] bind))- | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GRHSs noExtField guards bind)) [refactoring]]+ | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GRHSs emptyComments guards bind)) [refactoring]] where rawGuards :: [(LHsExpr GhcPs, LHsExpr GhcPs)] rawGuards = asGuards bod mkGuard :: LHsExpr GhcPs -> (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs))- mkGuard a = GRHS noExtField [noLoc $ BodyStmt noExtField a noSyntaxExpr noSyntaxExpr]+ mkGuard a = GRHS EpAnnNotUsed [noLocA $ BodyStmt noExtField a noSyntaxExpr noSyntaxExpr] guards :: [LGRHS GhcPs (LHsExpr GhcPs)] guards = map (noLoc . uncurry mkGuard) rawGuards@@ -128,7 +128,7 @@ -- Check if the expression has been injected or is natural. zipWith checkLoc ps ['1' .. '9'] where- checkLoc p@(L l _) v = if l == noSrcSpan then Left p else Right (c ++ [v], toSS p)+ checkLoc p@(L l _) v = if locA l == noSrcSpan then Left p else Right (c ++ [v], toSSA p) patSubts = case pat of@@ -144,20 +144,20 @@ toString' (Left e) = e toString' (Right (v, _)) = strToPat v - template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString' patSubts) (GRHSs noExtField templateGuards bind)) [])+ template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString' patSubts) (GRHSs emptyComments templateGuards bind)) []) f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)] f = rights refactoring = Replace rtype (toRefactSrcSpan l) (f patSubts ++ f guardSubts ++ f exprSubts) template hints gen (Pattern l t pats o@(GRHSs _ [L _ (GRHS _ [test] bod)] bind)) | unsafePrettyPrint test `elem` ["otherwise", "True"]- = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLoc (GRHS noExtField [] bod)]}) [Delete Stmt (toSS test)]]+ = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLoc (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- f :: LHsLocalBinds GhcPs -> Bool- f (L _ (HsValBinds _ (ValBinds _ bag _))) = isEmptyBag bag- f (L _ (HsIPBinds _ (IPBinds _ l))) = null l+ f :: HsLocalBinds GhcPs -> Bool+ f (HsValBinds _ (ValBinds _ bag _)) = isEmptyBag bag+ f (HsIPBinds _ (IPBinds _ l)) = null l f _ = False whereSpan = case l of UnhelpfulSpan s -> UnhelpfulSpan s@@ -167,8 +167,8 @@ in RealSrcSpan (mkRealSrcSpan start end) Nothing hints gen (Pattern l t pats o@(GRHSs _ (unsnoc -> Just (gs, L _ (GRHS _ [test] bod))) binds)) | unsafePrettyPrint test == "True"- = let otherwise_ = noLoc $ BodyStmt noExtField (strToVar "otherwise") noSyntaxExpr noSyntaxExpr in- [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLoc (GRHS noExtField [otherwise_] bod)]}) [Replace Expr (toSS test) [] "otherwise"]]+ = let otherwise_ = noLocA $ BodyStmt noExtField (strToVar "otherwise") noSyntaxExpr noSyntaxExpr in+ [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLoc (GRHS EpAnnNotUsed [otherwise_] bod)]}) [Replace Expr (toSSA test) [] "otherwise"]] hints _ _ = [] asGuards :: LHsExpr GhcPs -> [(LHsExpr GhcPs, LHsExpr GhcPs)]@@ -183,27 +183,27 @@ asPattern (L loc x) = concatMap decl (universeBi x) where decl :: HsBind GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]- decl o@(PatBind _ pat rhs _) = [(Pattern loc Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest msg (L loc o :: LHsBind GhcPs) (noLoc (PatBind noExtField pat rhs ([], [])) :: LHsBind GhcPs) rs)]+ decl 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 _ = [] match :: LMatch GhcPs (LHsExpr GhcPs) -> (Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)- match o@(L loc (Match _ ctx pats grhss)) = (Pattern loc R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest msg o (noLoc (Match noExtField ctx pats grhss) :: LMatch GhcPs (LHsExpr GhcPs)) rs)+ match o@(L loc (Match _ ctx 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) -- First Bool is if 'Strict' is a language extension. Second Bool is -- if this pattern in this context is going to be evaluated strictly. patHint :: Bool -> Bool -> LPat GhcPs -> [Idea]-patHint _ _ o@(L _ (ConPat _ name (PrefixCon args)))+patHint _ _ o@(L _ (ConPat _ name (PrefixCon _ args))) | length args >= 3 && all isPWildcard args = let rec_fields = HsRecFields [] Nothing :: HsRecFields GhcPs (LPat GhcPs)- new = noLoc $ ConPat noExtField name (RecCon rec_fields) :: LPat GhcPs+ new = noLocA $ ConPat EpAnnNotUsed name (RecCon rec_fields) :: LPat GhcPs in- [suggest "Use record patterns" o new [Replace R.Pattern (toSS o) [] (unsafePrettyPrint new)]]+ [suggest "Use record patterns" (reLoc o) (reLoc new) [Replace R.Pattern (toSSA o) [] (unsafePrettyPrint new)]] patHint _ _ o@(L _ (VarPat _ (L _ name))) | occNameString (rdrNameOcc name) == "otherwise" =- [warn "Used otherwise as a pattern" o (noLoc (WildPat noExtField) :: LPat GhcPs) []]+ [warn "Used otherwise as a pattern" (reLoc o) (noLoc (WildPat noExtField) :: Located (Pat GhcPs)) []] patHint lang strict o@(L _ (BangPat _ pat@(L _ x)))- | strict, f x = [warn "Redundant bang pattern" o (noLoc x :: LPat GhcPs) [r]]+ | strict, f x = [warn "Redundant bang pattern" (reLoc o) (noLoc x :: Located (Pat GhcPs)) [r]] where f :: Pat GhcPs -> Bool f (ParPat _ (L _ x)) = f x@@ -215,9 +215,9 @@ f ListPat {} = True f (SigPat _ (L _ p) _) = f p f _ = False- r = Replace R.Pattern (toSS o) [("x", toSS pat)] "x"+ r = Replace R.Pattern (toSSA o) [("x", toSSA pat)] "x" patHint False _ o@(L _ (LazyPat _ pat@(L _ x)))- | f x = [warn "Redundant irrefutable pattern" o (noLoc x :: LPat GhcPs) [r]]+ | f x = [warn "Redundant irrefutable pattern" (reLoc o) (noLoc x :: Located (Pat GhcPs)) [r]] where f :: Pat GhcPs -> Bool f (ParPat _ (L _ x)) = f x@@ -225,20 +225,20 @@ f WildPat{} = True f VarPat{} = True f _ = False- r = Replace R.Pattern (toSS o) [("x", toSS pat)] "x"+ r = Replace R.Pattern (toSSA o) [("x", toSSA pat)] "x" patHint _ _ o@(L _ (AsPat _ v (L _ (WildPat _)))) =- [warn "Redundant as-pattern" o v [Replace R.Pattern (toSS o) [] (rdrNameStr v)]]+ [warn "Redundant as-pattern" (reLoc o) (reLoc v) [Replace R.Pattern (toSSA o) [] (rdrNameStr v)]] patHint _ _ _ = [] expHint :: LHsExpr GhcPs -> [Idea] -- Note the 'FromSource' in these equations (don't warn on generated match groups).-expHint o@(L _ (HsCase _ _ (MG _ (L _ [L _ (Match _ CaseAlt [L _ (WildPat _)] (GRHSs _ [L _ (GRHS _ [] e)] (L _ (EmptyLocalBinds _)))) ]) FromSource ))) =- [suggest "Redundant case" o e [r]]+expHint o@(L _ (HsCase _ _ (MG _ (L _ [L _ (Match _ CaseAlt [L _ (WildPat _)] (GRHSs _ [L _ (GRHS _ [] e)] (EmptyLocalBinds _))) ]) FromSource ))) =+ [suggest "Redundant case" (reLoc o) (reLoc e) [r]] where- r = Replace Expr (toSS o) [("x", toSS e)] "x"-expHint o@(L _ (HsCase _ (L _ (HsVar _ (L _ x))) (MG _ (L _ [L _ (Match _ CaseAlt [L _ (VarPat _ (L _ y))] (GRHSs _ [L _ (GRHS _ [] e)] (L _ (EmptyLocalBinds _)))) ]) FromSource )))+ r = Replace Expr (toSSA o) [("x", toSSA e)] "x"+expHint o@(L _ (HsCase _ (L _ (HsVar _ (L _ x))) (MG _ (L _ [L _ (Match _ CaseAlt [L _ (VarPat _ (L _ y))] (GRHSs _ [L _ (GRHS _ [] e)] (EmptyLocalBinds _))) ]) FromSource ))) | occNameStr x == occNameStr y =- [suggest "Redundant case" o e [r]]+ [suggest "Redundant case" (reLoc o) (reLoc e) [r]] where- r = Replace Expr (toSS o) [("x", toSS e)] "x"+ r = Replace Expr (toSSA o) [("x", toSSA e)] "x" expHint _ = []
src/Hint/Pragma.hs view
@@ -32,28 +32,29 @@ module Hint.Pragma(pragmaHint) where -import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),toSS,rawIdea)+import Hint.Type(ModuHint,Idea(..),Severity(..),toSSAnc,rawIdea,modComments) import Data.List.Extra import qualified Data.List.NonEmpty as NE import Data.Maybe import Refact.Types import qualified Refact.Types as R -import GHC.Parser.Annotation+import GHC.Hs import GHC.Types.SrcLoc+import GHC.Data.FastString import GHC.Util import GHC.Driver.Session pragmaHint :: ModuHint pragmaHint _ modu =- let ps = pragmas (ghcAnnotations modu)+ let ps = pragmas (modComments modu) opts = flags ps lang = languagePragmas ps in languageDupes lang ++ optToPragma opts lang -optToPragma :: [(Located AnnotationComment, [String])]- -> [(Located AnnotationComment, [String])]+optToPragma :: [(LEpaComment, [String])]+ -> [(LEpaComment, [String])] -> [Idea] optToPragma flags languagePragmas = [pragmaIdea (OptionsToComment (fst <$> old2) ys rs) | Just old2 <- [NE.nonEmpty old]]@@ -66,40 +67,44 @@ ls = concatMap snd languagePragmas ns2 = nubOrd (concat ns) \\ ls - ys = [mkLanguagePragmas noSrcSpan ns2 | ns2 /= []] ++ catMaybes new- mkRefact :: (Located AnnotationComment, [String])- -> Maybe (Located AnnotationComment)+ dummyLoc = mkRealSrcLoc (fsLit "dummy") 1 1+ dummySpan = mkRealSrcSpan dummyLoc dummyLoc+ dummyAnchor = realSpanAsAnchor dummySpan++ ys = [mkLanguagePragmas dummyAnchor ns2 | ns2 /= []] ++ catMaybes new+ mkRefact :: (LEpaComment, [String])+ -> Maybe LEpaComment -> [String] -> Refactoring R.SrcSpan- mkRefact old (maybe "" comment -> new) ns =- let ns' = map (\n -> comment (mkLanguagePragmas noSrcSpan [n])) ns- in ModifyComment (toSS (fst old)) (intercalate "\n" (filter (not . null) (ns' `snoc` new)))+ mkRefact old (maybe "" comment_ -> new) ns =+ let ns' = map (\n -> comment_ (mkLanguagePragmas dummyAnchor [n])) ns+ in ModifyComment (toSSAnc (fst old)) (intercalate "\n" (filter (not . null) (ns' `snoc` new))) -data PragmaIdea = SingleComment (Located AnnotationComment) (Located AnnotationComment)- | MultiComment (Located AnnotationComment) (Located AnnotationComment) (Located AnnotationComment)- | OptionsToComment (NE.NonEmpty (Located AnnotationComment)) [Located AnnotationComment] [Refactoring R.SrcSpan]+data PragmaIdea = SingleComment LEpaComment LEpaComment+ | MultiComment LEpaComment LEpaComment LEpaComment+ | OptionsToComment (NE.NonEmpty LEpaComment) [LEpaComment] [Refactoring R.SrcSpan] pragmaIdea :: PragmaIdea -> Idea pragmaIdea pidea = case pidea of SingleComment old new ->- mkFewer (getLoc old) (comment old) (Just $ comment new) []- [ModifyComment (toSS old) (comment new)]+ mkFewer (getAncLoc old) (comment_ old) (Just $ comment_ new) []+ [ModifyComment (toSSAnc old) (comment_ new)] MultiComment repl delete new ->- mkFewer (getLoc repl)- (f [repl, delete]) (Just $ comment new) []- [ ModifyComment (toSS repl) (comment new)- , ModifyComment (toSS delete) ""]+ mkFewer (getAncLoc repl)+ (f [repl, delete]) (Just $ comment_ new) []+ [ ModifyComment (toSSAnc repl) (comment_ new)+ , ModifyComment (toSSAnc delete) ""] OptionsToComment old new r ->- mkLanguage (getLoc . NE.head $ old)+ mkLanguage (getAncLoc . NE.head $ old) (f $ NE.toList old) (Just $ f new) [] r where- f = unlines . map comment+ f = unlines . map comment_ mkFewer = rawIdea Hint.Type.Warning "Use fewer LANGUAGE pragmas" mkLanguage = rawIdea Hint.Type.Warning "Use LANGUAGE pragmas" -languageDupes :: [(Located AnnotationComment, [String])] -> [Idea]+languageDupes :: [(LEpaComment, [String])] -> [Idea] languageDupes ( (a@(L l _), les) : cs ) = (if nubOrd les /= les then [pragmaIdea (SingleComment a (mkLanguagePragmas l $ nubOrd les))]@@ -126,9 +131,9 @@ -- extension enabling flags. Return that together with a list of any -- language extensions enabled by this pragma that are not otherwise -- enabled by LANGUAGE pragmas in the module.-optToLanguage :: (Located AnnotationComment, [String])+optToLanguage :: (LEpaComment, [String]) -> [String]- -> Maybe (Maybe (Located AnnotationComment), [String])+ -> Maybe (Maybe LEpaComment, [String]) optToLanguage (L loc _, flags) languagePragmas | any isJust vs = -- 'ls' is a list of language features enabled by this
src/Hint/Restrict.hs view
@@ -20,7 +20,7 @@ </TEST> -} -import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),warn,rawIdea)+import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),warn,rawIdea,modComments) import Config.Type import Util @@ -29,16 +29,18 @@ import qualified Data.Set as Set import qualified Data.Map as Map import Data.List.Extra+import Data.List.NonEmpty (nonEmpty) import Data.Maybe+import Data.Monoid import Data.Semigroup import Data.Tuple.Extra import Control.Applicative import Control.Monad+import Control.Monad.Extra import Prelude import GHC.Hs import GHC.Types.Name.Reader-import GHC.Parser.Annotation import GHC.Unit.Module import GHC.Types.SrcLoc import GHC.Types.Name.Occurrence@@ -49,7 +51,7 @@ -- FIXME: The settings should be partially applied, but that's hard to orchestrate right now restrictHint :: [Setting] -> ModuHint restrictHint settings scope m =- let anns = ghcAnnotations m+ let anns = modComments m ps = pragmas anns opts = flags ps exts = languagePragmas ps in@@ -65,13 +67,18 @@ data RestrictItem = RestrictItem {riAs :: [String]+ ,riAsRequired :: Alt Maybe Bool+ ,riImportStyle :: Alt Maybe RestrictImportStyle+ ,riQualifiedStyle :: Alt Maybe QualifiedStyle ,riWithin :: [(String, String)] ,riRestrictIdents :: RestrictIdents ,riMessage :: Maybe String } instance Semigroup RestrictItem where- RestrictItem x1 x2 x3 x4 <> RestrictItem y1 y2 y3 y4 = RestrictItem (x1<>y1) (x2<>y2) (x3<>y3) (x4<>y4)+ RestrictItem x1 x2 x3 x4 x5 x6 x7+ <> RestrictItem y1 y2 y3 y4 y5 y6 y7+ = RestrictItem (x1<>y1) (x2<>y2) (x3<>y3) (x4<>y4) (x5<>y5) (x6<>y6) (x7<>y7) -- Contains a map from module (Nothing if the rule is unqualified) to (within, message), so that we can -- distinguish functions with the same name.@@ -97,7 +104,17 @@ rOthers = Map.map f $ Map.fromListWith (++) (map (second pure) ros) f rs = (all restrictDefault rs- ,Map.fromListWith (<>) [(s, RestrictItem restrictAs restrictWithin restrictIdents restrictMessage) | Restrict{..} <- rs, s <- restrictName])+ ,Map.fromListWith (<>)+ [(,) s RestrictItem+ { riAs = restrictAs+ , riAsRequired = restrictAsRequired+ , riImportStyle = restrictImportStyle+ , riQualifiedStyle = restrictQualifiedStyle+ , riWithin = restrictWithin+ , riRestrictIdents = restrictIdents+ , riMessage = restrictMessage+ }+ | Restrict{..} <- rs, s <- restrictName]) ideaMessage :: Maybe String -> Idea -> Idea ideaMessage (Just message) w = w{ideaNote=[Note message]}@@ -110,23 +127,24 @@ noteMayBreak = Note "may break the code" within :: String -> String -> [(String, String)] -> Bool-within modu func = any (\(a,b) -> (a == modu || a == "") && (b == func || b == ""))+within modu func = any (\(a,b) -> (a ~= modu || a == "") && (b ~= func || b == ""))+ where (~=) = wildcardMatch --------------------------------------------------------------------- -- CHECKS checkPragmas :: String- -> [(Located AnnotationComment, [String])]- -> [(Located AnnotationComment, [String])]+ -> [(LEpaComment, [String])]+ -> [(LEpaComment, [String])] -> Map.Map RestrictType (Bool, Map.Map String RestrictItem) -> [Idea] checkPragmas modu flags exts mps = f RestrictFlag "flags" flags ++ f RestrictExtension "extensions" exts where f tag name xs =- [(if null good then ideaNoTo else id) $ notes $ rawIdea Hint.Type.Warning ("Avoid restricted " ++ name) l c Nothing [] []+ [(if null good then ideaNoTo else id) $ notes $ rawIdea Hint.Type.Warning ("Avoid restricted " ++ name) (getAncLoc l) c Nothing [] [] | Just (def, mp) <- [Map.lookup tag mps]- , (L l (AnnBlockComment c), les) <- xs+ , (l@(L _ (EpaComment (EpaBlockComment c) _)), les) <- xs , let (good, bad) = partition (isGood def mp) les , let note = maybe noteMayBreak Note . (=<<) riMessage . flip Map.lookup mp , let notes w = w {ideaNote=note <$> bad}@@ -141,7 +159,7 @@ let RestrictItem{..} = getRestrictItem def ideclName mp either (Just . ideaMessage riMessage) (const Nothing) $ do unless (within modu "" riWithin) $- Left $ ideaNoTo $ warn "Avoid restricted module" i i []+ Left $ ideaNoTo $ warn "Avoid restricted module" (reLoc i) (reLoc i) [] let importedIdents = Set.fromList $ case ideclHiding of@@ -152,28 +170,63 @@ ForbidIdents badIdents -> importedIdents `Set.intersection` Set.fromList badIdents OnlyIdents onlyIdents -> importedIdents `Set.difference` Set.fromList onlyIdents unless (Set.null invalidIdents) $- Left $ ideaNoTo $ warn "Avoid restricted identifiers" i i []+ Left $ ideaNoTo $ warn "Avoid restricted identifiers" (reLoc i) (reLoc i) [] let qualAllowed = case (riAs, ideclAs) of ([], _) -> True- (_, Nothing) -> True+ (_, Nothing) -> maybe True not $ getAlt riAsRequired (_, Just (L _ modName)) -> moduleNameString modName `elem` riAs unless qualAllowed $ do- let i' = noLoc $ (unLoc i){ ideclAs = noLoc . mkModuleName <$> listToMaybe riAs }- Left $ warn "Avoid restricted qualification" i i' []+ let i' = noLoc $ (unLoc i){ ideclAs = noLocA . mkModuleName <$> listToMaybe riAs }+ Left $ warn "Avoid restricted alias" (reLoc i) i' [] -getRestrictItem :: Bool -> Located ModuleName -> Map.Map String RestrictItem -> RestrictItem-getRestrictItem def ideclName = fromMaybe (RestrictItem [] [("","") | def] NoRestrictIdents Nothing) . lookupRestrictItem ideclName+ let (expectedQual, expectedHiding) =+ case fromMaybe ImportStyleUnrestricted $ getAlt riImportStyle of+ ImportStyleUnrestricted+ | NotQualified <- ideclQualified -> (Nothing, Nothing)+ | otherwise -> (second (<> " or unqualified") <$> expectedQualStyle, Nothing)+ ImportStyleQualified -> (expectedQualStyleDef, Nothing)+ ImportStyleExplicitOrQualified+ | Just (False, _) <- ideclHiding -> (Nothing, Nothing)+ | otherwise ->+ ( second (<> " or with an explicit import list") <$> expectedQualStyleDef+ , Nothing )+ ImportStyleExplicit+ | Just (False, _) <- ideclHiding -> (Nothing, Nothing)+ | otherwise ->+ ( Just (NotQualified, "unqualified")+ , Just $ Just (False, noLocA []) )+ ImportStyleUnqualified -> (Just (NotQualified, "unqualified"), Nothing)+ expectedQualStyleDef = expectedQualStyle <|> Just (QualifiedPre, "qualified")+ expectedQualStyle =+ case fromMaybe QualifiedStyleUnrestricted $ getAlt riQualifiedStyle of+ QualifiedStyleUnrestricted -> Nothing+ QualifiedStylePost -> Just (QualifiedPost, "post-qualified")+ QualifiedStylePre -> Just (QualifiedPre, "pre-qualified")+ qualIdea+ | Just ideclQualified == (fst <$> expectedQual) = Nothing+ | otherwise = expectedQual+ whenJust qualIdea $ \(qual, hint) -> do+ let i' = noLoc $ (unLoc i){ ideclQualified = qual+ , ideclHiding = fromMaybe ideclHiding expectedHiding }+ msg = moduleNameString (unLoc ideclName) <> " should be imported " <> hint+ Left $ warn msg (reLoc i) i' [] -lookupRestrictItem :: Located ModuleName -> Map.Map String RestrictItem -> Maybe RestrictItem+getRestrictItem :: Bool -> LocatedA ModuleName -> Map.Map String RestrictItem -> RestrictItem+getRestrictItem def ideclName =+ fromMaybe (RestrictItem mempty mempty mempty mempty [("","") | def] NoRestrictIdents Nothing)+ . lookupRestrictItem ideclName++lookupRestrictItem :: LocatedA ModuleName -> Map.Map String RestrictItem -> Maybe RestrictItem lookupRestrictItem ideclName mp = let moduleName = moduleNameString $ unLoc ideclName exact = Map.lookup moduleName mp- wildcard = fmap snd- . find (flip wildcardMatch moduleName . fst)- . filter (elem '*' . fst)+ wildcard = nonEmpty+ . fmap snd+ . reverse -- the hope is less specific matches will end up last, but it's not guaranteed+ . filter (liftA2 (&&) (elem '*') (`wildcardMatch` moduleName) . fst) $ Map.toList mp- in exact <|> wildcard+ in exact <> sconcat (sequence wildcard) importListToIdents :: IE GhcPs -> [String] importListToIdents =@@ -181,14 +234,15 @@ \case (IEVar _ n) -> [fromName n] (IEThingAbs _ n) -> [fromName n] (IEThingAll _ n) -> [fromName n]- (IEThingWith _ n _ ns _) -> fromName n : map fromName ns+ (IEThingWith _ n _ ns) -> fromName n : map fromName ns _ -> [] where fromName :: LIEWrappedName (IdP GhcPs) -> Maybe String- fromName wrapped = case unLoc wrapped of- IEName n -> fromId (unLoc n)- IEPattern n -> ("pattern " ++) <$> fromId (unLoc n)- IEType n -> ("type " ++) <$> fromId (unLoc n)+ fromName wrapped =+ case unLoc wrapped of+ IEName n -> fromId (unLoc n)+ IEPattern _ n -> ("pattern " ++) <$> fromId (unLoc n)+ IEType _ n -> ("type " ++) <$> fromId (unLoc n) fromId :: IdP GhcPs -> Maybe String fromId (Unqual n) = Just $ occNameString n@@ -198,10 +252,10 @@ checkFunctions :: Scope -> String -> [LHsDecl GhcPs] -> RestrictFunctions -> [Idea] checkFunctions scope modu decls (def, mp) =- [ (ideaMessage message $ ideaNoTo $ warn "Avoid restricted function" x x []){ideaDecl = [dname]}+ [ (ideaMessage message $ ideaNoTo $ warn "Avoid restricted function" (reLocN x) (reLocN x) []){ideaDecl = [dname]} | d <- decls , let dname = fromMaybe "" (declName d)- , x <- universeBi d :: [Located RdrName]+ , x <- universeBi d :: [LocatedN RdrName] , let xMods = possModules scope x , let (withins, message) = fromMaybe ([("","") | def], Nothing) (findFunction mp x xMods) , not $ within modu dname withins@@ -213,7 +267,7 @@ -- withins and messages are concatenated with (<>). findFunction :: Map.Map String RestrictFunction- -> Located RdrName+ -> LocatedN RdrName -> [ModuleName] -> Maybe ([(String, String)], Maybe String) findFunction restrictMap (rdrNameStr -> x) (map moduleNameString -> possMods) = do
src/Hint/Smell.hs view
@@ -1,8 +1,5 @@ -module Hint.Smell (- smellModuleHint,- smellHint- ) where+module Hint.Smell (smellModuleHint,smellHint) where {- <TEST> [{smell: { type: many arg functions, limit: 2 }}]@@ -85,9 +82,9 @@ import Data.List.Extra import qualified Data.Map as Map +import GHC.Utils.Outputable import GHC.Types.Basic import GHC.Hs-import GHC.Utils.Outputable import GHC.Data.Bag import GHC.Types.SrcLoc import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable@@ -98,7 +95,7 @@ imports = hsmodImports mod in case Map.lookup SmellManyImports (smells settings) of Just n | length imports >= n ->- let span = foldl1 combineSrcSpans $ getLoc <$> imports+ let span = foldl1 combineSrcSpans $ locA . getLoc <$> imports displayImports = unlines $ f <$> imports in [rawIdea Config.Type.Warning "Many imports" span displayImports Nothing [] [] ] where@@ -140,18 +137,18 @@ -- the where clause. rhsSpans ctx locGrhs ++ whereSpans where_ -- Any other kind of function.-declSpans f@(L l (ValD _ FunBind {})) = [(l, warn "Long function" f f [])]+declSpans f@(L l (ValD _ FunBind {})) = [(locA l, warn "Long function" (reLoc f) (reLoc f) [])] declSpans _ = [] -- The span of a guarded right hand side. rhsSpans :: HsMatchContext GhcPs -> LGRHS GhcPs (LHsExpr GhcPs) -> [(SrcSpan, Idea)] rhsSpans _ (L _ (GRHS _ _ (L _ RecordCon {}))) = [] -- record constructors get a pass rhsSpans ctx (L _ r@(GRHS _ _ (L l _))) =- [(l, rawIdea Config.Type.Warning "Long function" l (showSDocUnsafe (pprGRHS ctx r)) Nothing [] [])]+ [(locA l, rawIdea Config.Type.Warning "Long function" (locA l) (showSDocUnsafe (pprGRHS ctx r)) Nothing [] [])] -- The spans of a 'where' clause are the spans of its bindings.-whereSpans :: LHsLocalBinds GhcPs -> [(SrcSpan, Idea)]-whereSpans (L l (HsValBinds _ (ValBinds _ bs _))) =+whereSpans :: HsLocalBinds GhcPs -> [(SrcSpan, Idea)]+whereSpans (HsValBinds _ (ValBinds _ bs _)) = concatMap (declSpans . (\(L loc bind) -> L loc (ValD noExtField bind))) (bagToList bs) whereSpans _ = [] @@ -160,16 +157,16 @@ spanLength (UnhelpfulSpan _) = -1 smellLongTypeLists :: LHsDecl GhcPs -> Int -> [Idea]-smellLongTypeLists d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (L _ t)))))) n =- warn "Long type list" d d [] <$ filter longTypeList (universe t)+smellLongTypeLists d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (L _ (HsSig _ _ (L _ t))))))) n =+ warn "Long type list" (reLoc d) (reLoc d) [] <$ filter longTypeList (universe t) where longTypeList (HsExplicitListTy _ IsPromoted x) = length x >= n longTypeList _ = False smellLongTypeLists _ _ = [] smellManyArgFunctions :: LHsDecl GhcPs -> Int -> [Idea]-smellManyArgFunctions d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (L _ t)))))) n =- warn "Many arg function" d d [] <$ filter manyArgFunction (universe t)+smellManyArgFunctions d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (L _ (HsSig _ _ (L _ t))))))) n =+ warn "Many arg function" (reLoc d) (reLoc d) [] <$ filter manyArgFunction (universe t) where manyArgFunction t = countFunctionArgs t >= n smellManyArgFunctions _ _ = []
src/Hint/Unsafe.hs view
@@ -18,7 +18,7 @@ module Hint.Unsafe(unsafeHint) where -import Hint.Type(DeclHint,ModuleEx(..),Severity(..),rawIdea,toSS)+import Hint.Type(DeclHint,ModuleEx(..),Severity(..),rawIdea,toSSA) import Data.List.Extra import Refact.Types hiding(Match) import Data.Generics.Uniplate.DataOnly@@ -28,6 +28,7 @@ import GHC.Types.Name.Reader import GHC.Data.FastString import GHC.Types.Basic+import GHC.Types.SourceText import GHC.Types.SrcLoc import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable@@ -45,11 +46,11 @@ -- @ -- is. We advise that such constants should have a @NOINLINE@ pragma. unsafeHint :: DeclHint-unsafeHint _ (ModuleEx (L _ m) _) = \(L loc d) ->- [rawIdea Hint.Type.Warning "Missing NOINLINE pragma" loc+unsafeHint _ (ModuleEx (L _ m)) = \ld@(L loc d) ->+ [rawIdea Hint.Type.Warning "Missing NOINLINE pragma" (locA loc) (unsafePrettyPrint d) (Just $ trimStart (unsafePrettyPrint $ gen x) ++ "\n" ++ unsafePrettyPrint d)- [] [InsertComment (toSS (L loc d)) (unsafePrettyPrint $ gen x)]+ [] [InsertComment (toSSA ld) (unsafePrettyPrint $ gen x)] -- 'x' does not declare a new function. | d@(ValD _ FunBind {fun_id=L _ (Unqual x)@@ -60,8 +61,8 @@ , x `notElem` noinline] where gen :: OccName -> LHsDecl GhcPs- gen x = noLoc $- SigD noExtField (InlineSig noExtField (noLoc (mkRdrUnqual x))+ gen x = noLocA $+ SigD noExtField (InlineSig EpAnnNotUsed (noLocA (mkRdrUnqual x)) (InlinePragma (SourceText "{-# NOINLINE") NoInline Nothing NeverActive FunLike)) noinline :: [OccName] noinline = [q | L _(SigD _ (InlineSig _ (L _ (Unqual q))
src/Language/Haskell/HLint.hs view
@@ -23,7 +23,7 @@ -- * Hints Hint, -- * Modules- ModuleEx, parseModuleEx, createModuleEx, ParseError(..),+ ModuleEx, parseModuleEx, createModuleEx, createModuleExWithFixities, ParseError(..), -- * Parse flags defaultParseFlags, ParseFlags(..), CppFlags(..), FixityInfo,@@ -49,6 +49,7 @@ import System.FilePath import Data.Functor import Prelude+import qualified Hint.Restrict as Restrict -- | Get the Cabal configured data directory of HLint.@@ -116,7 +117,9 @@ splitSettings xs = ([x | Infix x <- xs] ,[x | SettingClassify x <- xs]- ,H.resolveHints $ [Right x | SettingMatchExp x <- xs] ++ map Left enumerate)+ ,H.resolveHints ([Right x | SettingMatchExp x <- xs] ++ map Left enumerate)+ <> mempty { hintModule = Restrict.restrictHint . (xs++)}+ ) -- | Given a way of classifying results, and a 'Hint', apply to a set of modules generating a list of 'Idea's.
src/Refact.hs view
@@ -3,7 +3,7 @@ module Refact ( substVars , toRefactSrcSpan- , toSS+ , toSS, toSSA, toSSAnc , checkRefactor, refactorPath, runRefactoring ) where @@ -20,7 +20,10 @@ import qualified Refact.Types as R import qualified GHC.Types.SrcLoc as GHC+import qualified GHC.Parser.Annotation as GHC +import GHC.Util.SrcLoc (getAncLoc)+ substVars :: [String] substVars = [letter : number | number <- "" : map show [0..], letter <- ['a'..'z']] @@ -38,6 +41,12 @@ -- opting instead to show @-1 -1 -1 -1@ coordinates. toSS :: GHC.Located a -> R.SrcSpan toSS = toRefactSrcSpan . GHC.getLoc++toSSA :: GHC.GenLocated (GHC.SrcSpanAnn' a) e -> R.SrcSpan+toSSA = toRefactSrcSpan . GHC.getLocA++toSSAnc :: GHC.GenLocated GHC.Anchor e -> R.SrcSpan+toSSAnc = toRefactSrcSpan . getAncLoc checkRefactor :: Maybe FilePath -> IO FilePath checkRefactor = refactorPath >=> either errorIO pure
src/Test/Annotations.hs view
@@ -123,7 +123,10 @@ open line | "<TEST>" `isPrefixOf` line = let suffix = dropPrefix "<TEST>" line- config = decodeEither' $ BS.pack suffix+ config =+ if isBuiltinYaml file+ then mapRight getConfigYamlBuiltin $ decodeEither' $ BS.pack suffix+ else mapRight getConfigYamlUser $ decodeEither' $ BS.pack suffix in case config of Left err -> Just [] Right config -> Just $ settingsFromConfigYaml [config]
+ tests/hintrule-implies-classify.test view
@@ -0,0 +1,12 @@+---------------------------------------------------------------------+RUN tests/hintrule-implies-classify.hs --hint=data/hintrule-implies-classify.yaml+FILE tests/hintrule-implies-classify.hs+x = mapM print [1, 2, 3]+OUTPUT+tests/hintrule-implies-classify.hs:1:5-8: Warning: Use traverse+Found:+ mapM+Perhaps:+ traverse++1 hint
+ tests/import_style.test view
@@ -0,0 +1,68 @@+---------------------------------------------------------------------+RUN tests/importStyle-1.hs --hint=data/import_style.yaml+FILE tests/importStyle-1.hs+import HypotheticalModule1+import HypotheticalModule2+import HypotheticalModule3+import qualified HypotheticalModule3.SomeModule+import HypotheticalModule3.SomeModule qualified+import qualified HypotheticalModule3.OtherSubModule+OUTPUT+tests/importStyle-1.hs:1:1-26: Warning: Avoid restricted alias+Found:+ import HypotheticalModule1+Perhaps:+ import HypotheticalModule1 as HM1+Note: may break the code++tests/importStyle-1.hs:2:1-26: Warning: HypotheticalModule2 should be imported qualified or with an explicit import list+Found:+ import HypotheticalModule2+Perhaps:+ import qualified HypotheticalModule2+Note: may break the code++tests/importStyle-1.hs:3:1-26: Warning: HypotheticalModule3 should be imported qualified+Found:+ import HypotheticalModule3+Perhaps:+ import qualified HypotheticalModule3+Note: may break the code++tests/importStyle-1.hs:4:1-47: Warning: HypotheticalModule3.SomeModule should be imported unqualified+Found:+ import qualified HypotheticalModule3.SomeModule+Perhaps:+ import HypotheticalModule3.SomeModule+Note: may break the code++tests/importStyle-1.hs:5:1-47: Warning: HypotheticalModule3.SomeModule should be imported unqualified+Found:+ import HypotheticalModule3.SomeModule qualified+Perhaps:+ import HypotheticalModule3.SomeModule+Note: may break the code++tests/importStyle-1.hs:6:1-51: Warning: HypotheticalModule3.OtherSubModule should be imported post-qualified or unqualified+Found:+ import qualified HypotheticalModule3.OtherSubModule+Perhaps:+ import HypotheticalModule3.OtherSubModule qualified+Note: may break the code++6 hints++---------------------------------------------------------------------+RUN tests/importStyle-2.hs --hint=data/import_style.yaml+FILE tests/importStyle-2.hs+import HypotheticalModule1 as HM1+import qualified HypotheticalModule2+import HypotheticalModule2 (a, b, c, d)+import qualified HypotheticalModule3+import HypotheticalModule3.SomeModule+import HypotheticalModule3.OtherSubModule qualified+import HypotheticalModule3.OtherSubModule+OUTPUT+No hints++---------------------------------------------------------------------
+ tests/no_explicit_cpp.test view
@@ -0,0 +1,17 @@+---------------------------------------------------------------------+RUN tests/NoExplicitCpp.hs -XHaskell2010+FILE tests/NoExplicitCpp.hs+-- We expect C-preprocessing despite `CPP` not being in the+-- enabled extensions implied by the command line. See issue+-- https://github.com/ndmitchell/hlint/issues/1360.+{-# LANGUAGE CPP #-}+#if 1+hlint = __HLINT__+#endif+OUTPUT+tests/NoExplicitCpp.hs:4:1-20: Warning: Avoid restricted extensions+Found:+ {-# LANGUAGE CPP #-}+Note: may break the code++1 hint
− tests/wildcard-import.test
@@ -1,27 +0,0 @@-----------------------------------------------------------------------RUN tests/wildcard-import-1.hs --hint=data/wildcard-import.yaml-FILE tests/wildcard-import-1.hs-import Data.Map.Lazy as Foo-OUTPUT-tests/wildcard-import-1.hs:1:1-27: Warning: Avoid restricted qualification-Found:- import Data.Map.Lazy as Foo-Perhaps:- import Data.Map.Lazy as Map-Note: may break the code--1 hint------------------------------------------------------------------------RUN tests/wildcard-import-2.hs --hint=data/wildcard-import.yaml-FILE tests/wildcard-import-2.hs-import Data.Map.Strict as Foo-OUTPUT-tests/wildcard-import-2.hs:1:1-29: Warning: Avoid restricted qualification-Found:- import Data.Map.Strict as Foo-Perhaps:- import Data.Map.Strict as Map-Note: may break the code--1 hint
− tests/wildcard.test
@@ -1,45 +0,0 @@-----------------------------------------------------------------------RUN tests/wildcard-1.hs --hint=data/wildcard.yaml-FILE tests/wildcard-1.hs-module SpecNoMatch where-main = print $ (\ _ -> 'a') ()-OUTPUT-tests/wildcard-1.hs:2:17-26: Suggestion: Use const-Found:- \ _ -> 'a'-Perhaps:- const 'a'--1 hint------------------------------------------------------------------------RUN tests/wildcard-2.hs --hint=data/wildcard.yaml-FILE tests/wildcard-2.hs-module Spec where-main = print $ (\ _ -> 'a') ()-OUTPUT-No hints------------------------------------------------------------------------RUN tests/wildcard-3.hs --hint=data/wildcard.yaml-FILE tests/wildcard-3.hs-module PrefixedSpec where-main = print $ (\ _ -> 'a') ()-OUTPUT-No hints------------------------------------------------------------------------RUN tests/wildcard-4.hs --hint=data/wildcard.yaml-FILE tests/wildcard-4.hs-module Namespaced.Spec where-main = print $ (\ _ -> 'a') ()-OUTPUT-No hints------------------------------------------------------------------------RUN tests/wildcard-5.hs --hint=data/wildcard.yaml-FILE tests/wildcard-5.hs-module Deeply.Nested.Spec where-main = print $ (\ _ -> 'a') ()-OUTPUT-No hints
+ tests/wildcards.test view
@@ -0,0 +1,816 @@+----+RUN tests/wildcards-a.hs --hint=data/wildcards.yaml+FILE tests/wildcards-a.hs+import A as Z+OUTPUT+tests/wildcards-a.hs:1:1-13: Warning: Avoid restricted alias+Found:+ import A as Z+Perhaps:+ import A as A+Note: may break the code++1 hint++----+RUN tests/wildcards-xa.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xa.hs+import XA as Z+OUTPUT+No hints++----+RUN tests/wildcards-x-a.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-a.hs+import X.A as Z+OUTPUT+No hints++----+RUN tests/wildcards-x-y-a.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-a.hs+import X.Y.A as Z+OUTPUT+No hints++----+RUN tests/wildcards-b.hs --hint=data/wildcards.yaml+FILE tests/wildcards-b.hs+import B as Z+OUTPUT+tests/wildcards-b.hs:1:1-13: Warning: Avoid restricted alias+Found:+ import B as Z+Perhaps:+ import B as B+Note: may break the code++1 hint++----+RUN tests/wildcards-xb.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xb.hs+import XB as Z+OUTPUT+tests/wildcards-xb.hs:1:1-14: Warning: Avoid restricted alias+Found:+ import XB as Z+Perhaps:+ import XB as B+Note: may break the code++1 hint++----+RUN tests/wildcards-x-b.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-b.hs+import X.B as Z+OUTPUT+No hints++----+RUN tests/wildcards-x-y-b.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-b.hs+import X.Y.B as Z+OUTPUT+No hints++----+RUN tests/wildcards-c.hs --hint=data/wildcards.yaml+FILE tests/wildcards-c.hs+import C as Z+OUTPUT+tests/wildcards-c.hs:1:1-13: Warning: Avoid restricted alias+Found:+ import C as Z+Perhaps:+ import C as C+Note: may break the code++1 hint++----+RUN tests/wildcards-xc.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xc.hs+import XC as Z+OUTPUT+No hints++----+RUN tests/wildcards-x-c.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-c.hs+import X.C as Z+OUTPUT+tests/wildcards-x-c.hs:1:1-15: Warning: Avoid restricted alias+Found:+ import X.C as Z+Perhaps:+ import X.C as C+Note: may break the code++1 hint++----+RUN tests/wildcards-x-y-c.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-c.hs+import X.Y.C as Z+OUTPUT+tests/wildcards-x-y-c.hs:1:1-17: Warning: Avoid restricted alias+Found:+ import X.Y.C as Z+Perhaps:+ import X.Y.C as C+Note: may break the code++1 hint++----+RUN tests/wildcards-d.hs --hint=data/wildcards.yaml+FILE tests/wildcards-d.hs+import D as Z+OUTPUT+tests/wildcards-d.hs:1:1-13: Warning: Avoid restricted alias+Found:+ import D as Z+Perhaps:+ import D as D+Note: may break the code++1 hint++----+RUN tests/wildcards-xd.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xd.hs+import XD as Z+OUTPUT+tests/wildcards-xd.hs:1:1-14: Warning: Avoid restricted alias+Found:+ import XD as Z+Perhaps:+ import XD as D+Note: may break the code++1 hint++----+RUN tests/wildcards-x-d.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-d.hs+import X.D as Z+OUTPUT+tests/wildcards-x-d.hs:1:1-15: Warning: Avoid restricted alias+Found:+ import X.D as Z+Perhaps:+ import X.D as D+Note: may break the code++1 hint++----+RUN tests/wildcards-x-y-d.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-d.hs+import X.Y.D as Z+OUTPUT+tests/wildcards-x-y-d.hs:1:1-17: Warning: Avoid restricted alias+Found:+ import X.Y.D as Z+Perhaps:+ import X.Y.D as D+Note: may break the code++1 hint++----+RUN tests/wildcards-e.hs --hint=data/wildcards.yaml+FILE tests/wildcards-e.hs+module E where import E+OUTPUT+No hints++----+RUN tests/wildcards-xe.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xe.hs+module XE where import E+OUTPUT+tests/wildcards-xe.hs:1:17-24: Warning: Avoid restricted module+Found:+ import E+Note: may break the code++1 hint++----+RUN tests/wildcards-x-e.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-e.hs+module X.E where import E+OUTPUT+tests/wildcards-x-e.hs:1:18-25: Warning: Avoid restricted module+Found:+ import E+Note: may break the code++1 hint++----+RUN tests/wildcards-x-y-e.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-e.hs+module X.Y.E where import E+OUTPUT+tests/wildcards-x-y-e.hs:1:20-27: Warning: Avoid restricted module+Found:+ import E+Note: may break the code++1 hint++----+RUN tests/wildcards-f.hs --hint=data/wildcards.yaml+FILE tests/wildcards-f.hs+module F where import F+OUTPUT+No hints++----+RUN tests/wildcards-xf.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xf.hs+module XF where import F+OUTPUT+No hints++----+RUN tests/wildcards-x-f.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-f.hs+module X.F where import F+OUTPUT+tests/wildcards-x-f.hs:1:18-25: Warning: Avoid restricted module+Found:+ import F+Note: may break the code++1 hint++----+RUN tests/wildcards-x-y-f.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-f.hs+module X.Y.F where import F+OUTPUT+tests/wildcards-x-y-f.hs:1:20-27: Warning: Avoid restricted module+Found:+ import F+Note: may break the code++1 hint++----+RUN tests/wildcards-g.hs --hint=data/wildcards.yaml+FILE tests/wildcards-g.hs+module G where import G+OUTPUT+No hints++----+RUN tests/wildcards-xg.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xg.hs+module XG where import G+OUTPUT+tests/wildcards-xg.hs:1:17-24: Warning: Avoid restricted module+Found:+ import G+Note: may break the code++1 hint++----+RUN tests/wildcards-x-g.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-g.hs+module X.G where import G+OUTPUT+No hints++----+RUN tests/wildcards-x-y-g.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-g.hs+module X.Y.G where import G+OUTPUT+No hints++----+RUN tests/wildcards-h.hs --hint=data/wildcards.yaml+FILE tests/wildcards-h.hs+module H where import H+OUTPUT+No hints++----+RUN tests/wildcards-xh.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xh.hs+module XH where import H+OUTPUT+No hints++----+RUN tests/wildcards-x-h.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-h.hs+module X.H where import H+OUTPUT+No hints++----+RUN tests/wildcards-x-y-h.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-h.hs+module X.Y.H where import H+OUTPUT+No hints++----+RUN tests/wildcards-u.hs --hint=data/wildcards.yaml+FILE tests/wildcards-u.hs+module U where import U+OUTPUT+No hints++----+RUN tests/wildcards-module-xu.hs --hint=data/wildcards.yaml+FILE tests/wildcards-module-xu.hs+module XU where import U+OUTPUT+No hints++----+RUN tests/wildcards-module-x-u.hs --hint=data/wildcards.yaml+FILE tests/wildcards-module-x-u.hs+module X.U where import U+OUTPUT+No hints++----+RUN tests/wildcards-module-x-y-u.hs --hint=data/wildcards.yaml+FILE tests/wildcards-module-x-y-u.hs+module X.Y.U where import U+OUTPUT+No hints++----+RUN tests/wildcards-import-xu.hs --hint=data/wildcards.yaml+FILE tests/wildcards-import-xu.hs+module U where import XU+OUTPUT+No hints++----+RUN tests/wildcards-import-x-u.hs --hint=data/wildcards.yaml+FILE tests/wildcards-import-x-u.hs+module U where import X.U+OUTPUT+No hints++----+RUN tests/wildcards-import-x-y-u.hs --hint=data/wildcards.yaml+FILE tests/wildcards-import-x-y-u.hs+module U where import X.Y.U+OUTPUT+No hints++----+RUN tests/wildcards-module-w.hs --hint=data/wildcards.yaml+FILE tests/wildcards-module-w.hs+module W where import U+OUTPUT+tests/wildcards-module-w.hs:1:16-23: Warning: Avoid restricted module+Found:+ import U+Note: may break the code++1 hint++----+RUN tests/wildcard-i.hs --hint=data/wildcards.yaml+FILE tests/wildcard-i.hs+module I where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-xi.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xi.hs+module XI where x = y (\ _ -> z)+OUTPUT+tests/wildcard-xi.hs:1:24-31: Suggestion: Use const+Found:+ \ _ -> z+Perhaps:+ const z++1 hint++----+RUN tests/wildcard-x-i.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-i.hs+module X.I where x = y (\ _ -> z)+OUTPUT+tests/wildcard-x-i.hs:1:25-32: Suggestion: Use const+Found:+ \ _ -> z+Perhaps:+ const z++1 hint++----+RUN tests/wildcard-x-y-i.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-i.hs+module X.Y.I where x = y (\ _ -> z)+OUTPUT+tests/wildcard-x-y-i.hs:1:27-34: Suggestion: Use const+Found:+ \ _ -> z+Perhaps:+ const z++1 hint++----+RUN tests/wildcard-j.hs --hint=data/wildcards.yaml+FILE tests/wildcard-j.hs+module J where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-xj.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xj.hs+module XJ where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-x-j.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-j.hs+module X.J where x = y (\ _ -> z)+OUTPUT+tests/wildcard-x-j.hs:1:25-32: Suggestion: Use const+Found:+ \ _ -> z+Perhaps:+ const z++1 hint++----+RUN tests/wildcard-x-y-j.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-j.hs+module X.Y.J where x = y (\ _ -> z)+OUTPUT+tests/wildcard-x-y-j.hs:1:27-34: Suggestion: Use const+Found:+ \ _ -> z+Perhaps:+ const z++1 hint++----+RUN tests/wildcard-k.hs --hint=data/wildcards.yaml+FILE tests/wildcard-k.hs+module K where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-xk.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xk.hs+module XK where x = y (\ _ -> z)+OUTPUT+tests/wildcard-xk.hs:1:24-31: Suggestion: Use const+Found:+ \ _ -> z+Perhaps:+ const z++1 hint++----+RUN tests/wildcard-x-k.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-k.hs+module X.K where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-x-y-k.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-k.hs+module X.Y.K where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-l.hs --hint=data/wildcards.yaml+FILE tests/wildcard-l.hs+module L where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-xl.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xl.hs+module XL where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-x-l.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-l.hs+module X.L where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-x-y-l.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-l.hs+module X.Y.L where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-m.hs --hint=data/wildcards.yaml+FILE tests/wildcard-m.hs+{-# LANGUAGE CPP #-} module M where+OUTPUT+No hints++----+RUN tests/wildcard-xm.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xm.hs+{-# LANGUAGE CPP #-} module XM where+OUTPUT+tests/wildcard-xm.hs:1:1-20: Warning: Avoid restricted extensions+Found:+ {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-x-m.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-m.hs+{-# LANGUAGE CPP #-} module X.M where+OUTPUT+tests/wildcard-x-m.hs:1:1-20: Warning: Avoid restricted extensions+Found:+ {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-x-y-m.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-m.hs+{-# LANGUAGE CPP #-} module X.Y.M where+OUTPUT+tests/wildcard-x-y-m.hs:1:1-20: Warning: Avoid restricted extensions+Found:+ {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-n.hs --hint=data/wildcards.yaml+FILE tests/wildcard-n.hs+{-# LANGUAGE CPP #-} module N where+OUTPUT+No hints++----+RUN tests/wildcard-xn.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xn.hs+{-# LANGUAGE CPP #-} module XN where+OUTPUT+No hints++----+RUN tests/wildcard-x-n.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-n.hs+{-# LANGUAGE CPP #-} module X.N where+OUTPUT+tests/wildcard-x-n.hs:1:1-20: Warning: Avoid restricted extensions+Found:+ {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-x-y-n.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-n.hs+{-# LANGUAGE CPP #-} module X.Y.N where+OUTPUT+tests/wildcard-x-y-n.hs:1:1-20: Warning: Avoid restricted extensions+Found:+ {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-o.hs --hint=data/wildcards.yaml+FILE tests/wildcard-o.hs+{-# LANGUAGE CPP #-} module O where+OUTPUT+No hints++----+RUN tests/wildcard-xo.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xo.hs+{-# LANGUAGE CPP #-} module XO where+OUTPUT+tests/wildcard-xo.hs:1:1-20: Warning: Avoid restricted extensions+Found:+ {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-x-o.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-o.hs+{-# LANGUAGE CPP #-} module X.O where+OUTPUT+No hints++----+RUN tests/wildcard-x-y-o.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-o.hs+{-# LANGUAGE CPP #-} module X.Y.O where+OUTPUT+No hints++----+RUN tests/wildcard-p.hs --hint=data/wildcards.yaml+FILE tests/wildcard-p.hs+{-# LANGUAGE CPP #-} module P where+OUTPUT+No hints++----+RUN tests/wildcard-xp.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xp.hs+{-# LANGUAGE CPP #-} module XP where+OUTPUT+No hints++----+RUN tests/wildcard-x-p.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-p.hs+{-# LANGUAGE CPP #-} module X.P where+OUTPUT+No hints++----+RUN tests/wildcard-x-y-p.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-p.hs+{-# LANGUAGE CPP #-} module X.Y.P where+OUTPUT+No hints++----+RUN tests/wildcard-q.hs --hint=data/wildcards.yaml+FILE tests/wildcard-q.hs+module Q where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-xq.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xq.hs+module XQ where x = read ""+OUTPUT+tests/wildcard-xq.hs:1:21-24: Warning: Avoid restricted function+Found:+ read+Note: may break the code++1 hint++----+RUN tests/wildcard-x-q.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-q.hs+module X.Q where x = read ""+OUTPUT+tests/wildcard-x-q.hs:1:22-25: Warning: Avoid restricted function+Found:+ read+Note: may break the code++1 hint++----+RUN tests/wildcard-x-y-q.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-q.hs+module X.Y.Q where x = read ""+OUTPUT+tests/wildcard-x-y-q.hs:1:24-27: Warning: Avoid restricted function+Found:+ read+Note: may break the code++1 hint++----+RUN tests/wildcard-r.hs --hint=data/wildcards.yaml+FILE tests/wildcard-r.hs+module R where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-xr.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xr.hs+module XR where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-x-r.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-r.hs+module X.R where x = read ""+OUTPUT+tests/wildcard-x-r.hs:1:22-25: Warning: Avoid restricted function+Found:+ read+Note: may break the code++1 hint++----+RUN tests/wildcard-x-y-r.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-r.hs+module X.Y.R where x = read ""+OUTPUT+tests/wildcard-x-y-r.hs:1:24-27: Warning: Avoid restricted function+Found:+ read+Note: may break the code++1 hint++----+RUN tests/wildcard-s.hs --hint=data/wildcards.yaml+FILE tests/wildcard-s.hs+module S where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-xs.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xs.hs+module XS where x = read ""+OUTPUT+tests/wildcard-xs.hs:1:21-24: Warning: Avoid restricted function+Found:+ read+Note: may break the code++1 hint++----+RUN tests/wildcard-x-s.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-s.hs+module X.S where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-x-y-s.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-s.hs+module X.Y.S where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-t.hs --hint=data/wildcards.yaml+FILE tests/wildcard-t.hs+module T where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-xt.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xt.hs+module XT where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-x-t.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-t.hs+module X.T where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-x-y-t.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-t.hs+module X.Y.T where x = read ""+OUTPUT+No hints