hlint 3.1.6 → 3.2
raw patch · 34 files changed
+516/−788 lines, 34 filesdep ~ansi-terminaldep ~ghc-lib-parser-exPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ansi-terminal, ghc-lib-parser-ex
API changes (from Hackage documentation)
Files
- CHANGES.txt +28/−0
- README.md +15/−9
- data/hlint.yaml +25/−5
- hlint.cabal +5/−8
- src/CmdLine.hs +18/−47
- src/Extension.hs +1/−2
- src/GHC/All.hs +47/−42
- src/GHC/Util/HsExpr.hs +3/−3
- src/GHC/Util/View.hs +8/−2
- src/Grep.hs +0/−41
- src/HLint.hs +28/−34
- src/Hint/Bracket.hs +5/−4
- src/Hint/Duplicate.hs +8/−8
- src/Hint/Export.hs +3/−3
- src/Hint/Extensions.hs +19/−3
- src/Hint/Lambda.hs +75/−56
- src/Hint/List.hs +7/−7
- src/Hint/Monad.hs +5/−4
- src/Hint/Naming.hs +6/−6
- src/Hint/NewType.hs +11/−11
- src/Hint/Pattern.hs +4/−4
- src/Hint/Pragma.hs +1/−1
- src/Hint/Type.hs +1/−1
- src/Hint/Unsafe.hs +9/−9
- src/Language/Haskell/HLint.hs +9/−13
- src/Refact.hs +12/−3
- src/Summary.hs +142/−0
- src/Test/All.hs +3/−13
- src/Test/Annotations.hs +13/−22
- src/Test/Proof.hs +0/−199
- src/Test/Summary.hs +0/−58
- src/Test/Translate.hs +0/−127
- src/Test/Util.hs +1/−42
- src/Timing.hs +4/−1
CHANGES.txt view
@@ -1,5 +1,33 @@ Changelog for HLint (* = breaking change) +3.2, released 2020-09-14+ #75, make Windows 10 use color terminals+ Make sure the extension removed matches what you called it+* #1124, make test into a flag rather than a mode, use --test+ #1073, add LHS/RHS hints to the summary+* Remove test --proof, --quickcheck and --typecheck, --tempdir+* #1123, delete grep mode+ #1122, show the --refactor command line with --loud+ #1120, enable refactoring for use section+ #1114, enable refactoring for redundant as-pattern+ #1116, enable refactoring for redundant section+ #1115, more TVar/TMVar hints+ #1113, suggest x >>= pure . f becomes x <&> f+ #1111, add hint for \x y -> (x,y) to (,), and for (,,)+ #1108, enable refactoring for redundant variable capture+ #1105, enable refactoring for more redundant return hints+ #1103, enable refactoring for Redundant void+ #1083, add hints for mempty as a function+ #1097, enable refactoring for more avoid lambda hints+ #1094, error on `-XFoo` if `Foo` is not a known extension+ #1090, improve --verbose to print more information+ #1085, support eta-reduce refactoring+ #780, ignore dist and dist-newstyle directories+ #1076, fix -XNoCpp and CPP around LANGUAGE extensions+ #1077, warn on unused StandaloneKindSignatures+ #1070, warn on unused ImportQualifiedPost+ #1067, require apply-refact 0.8.1.0 (fixes lots of bugs)+ #1064, don't remove OverloadedLists if there is a [] 3.1.6, released 2020-06-24 #1062, make sure matching inserts brackets if required #1058, weaken the self-definition check to match more things
README.md view
@@ -11,7 +11,7 @@ Bugs can be reported [on the bug tracker](https://github.com/ndmitchell/hlint/issues). There are some issues that I do not intend to fix: -* HLint operates on each module at a time in isolation, as a result HLint does not know about types or which names are in scope.+* HLint operates on each module at a time in isolation, as a result HLint does not know about types or which names are in scope. This decision is deliberate, allowing HLint to parallelise and be used incrementally on code that may not type-check. If fixities are required to parse the code properly, they [can be supplied](#why-doesnt-hlint-know-the-fixity-for-my-custom--operator). * The presence of `seq` may cause some hints (i.e. eta-reduction) to change the semantics of a program. * Some transformed programs may require additional type signatures, particularly if the transformations trigger the monomorphism restriction or involve rank-2 types. * Sometimes HLint will change the code in a way that causes values to default to different types, which may change the behaviour.@@ -55,6 +55,8 @@ The first hint is marked as an warning, because using `concatMap` in preference to the two separate functions is always desirable. In contrast, the removal of brackets is probably a good idea, but not always. Reasons that a hint might be a suggestion include requiring an additional import, something not everyone agrees on, and functions only available in more recent versions of the base library. +Any configuration can be done via [.hlint.yaml](#customizing-the-hints) file.+ **Bug reports:** The suggested replacement should be equivalent - please report all incorrect suggestions not mentioned as known limitations. ### Suggested usage@@ -93,6 +95,7 @@ * [lpaste](http://lpaste.net/) integrates with HLint - suggestions are shown at the bottom. * [hlint-test](https://hackage.haskell.org/package/hlint-test) helps you write a small test runner with HLint. * [hint-man](https://github.com/apps/hint-man) automatically submits reviews to opened pull requests in your repositories with inline hints.+* [CircleCI](https://circleci.com/orbs/registry/orb/haskell-works/hlint) has a plugin to run HLint more easily. ### Automatically Applying Hints @@ -100,10 +103,7 @@ When using `--refactor` you can pass additional options to the `refactor` binary using `--refactor-options` flag. Some useful flags include `-i` (which replaces the original file) and `-s` (which asks for confirmation before performing a hint). The `--with-refactor` flag can be used to specify an alternative location for the `refactor` binary. Simple bindings for [Vim](https://github.com/mpickering/hlint-refactor-vim), [Emacs](https://github.com/mpickering/hlint-refactor-mode) and [Atom](https://github.com/mpickering/hlint-refactor-atom) are available. -While the `--refactor` flag is useful, it is not complete or at the same level of quality as the rest of HLint:--* Some hints don't generate refactorings. Examples include excess duplication, renaming hints and eta reduction hints.-* There are bugs in the underlying `refactor` tool which cause the resultant file to be incorrect. For example, `[1,2..3]` comes out as `[12..3]` ([#389](https://github.com/ndmitchell/hlint/issues/389)), even if there isn't a hint that touches it.+While the `--refactor` flag is useful, not all hints support refactoring. See [hints.md](hints.md) for which hints don't support refactoring. ### Reports @@ -166,11 +166,15 @@ ### Why doesn't HLint know the fixity for my custom !@%$ operator? -HLint knows the fixities for all the operators in the base library, but no others. HLint works on a single file at a time, and does not resolve imports, so cannot see fixity declarations from imported modules. You can tell HLint about fixities by putting them in a hint file named `.hlint.yaml` with the syntax `- fixity: "infixr 5 !@%$"`. You can also use `--find` to automatically produce a list of fixity declarations in a file.+HLint knows the fixities for all the operators in the base library, as well as operators whose fixities are declared in the module being linted, but no others. HLint works on a single file at a time, and does not resolve imports, so cannot see fixity declarations from imported modules. You can tell HLint about fixities by putting them in a hint file named `.hlint.yaml` with the syntax `- fixity: "infixr 5 !@%$"`. You can also use `--find` to automatically produce a list of fixity declarations in a file. +### Which hints are ignored?++Some hints are off-by-default. Some are ignored by the configuration settings. To see all hints pass `--show`. This feature is often useful in conjunction with `--report` which shows the hints in an interactive web page, allowing them to be browsed broken down by hint.+ ### Which hints are used? -HLint uses the `hlint.yaml` file it ships with by default (containing things like the `concatMap` hint above), along with the first `.hlint.yaml` file it finds in the current directory or any parent thereof. To include other hints, pass `--hint=filename.yaml`. If you pass any `--with` hint you will need to explicitly add any `--hint` flags required.+HLint uses the `hlint.yaml` file it ships with by default (containing things like the `concatMap` hint above), along with the first `.hlint.yaml` file it finds in the current directory or any parent thereof. To include other hints, pass `--hint=filename.yaml`. ### Why do I sometimes get a "Note" with my hint? @@ -211,8 +215,10 @@ ### Why do I get a parse error? -HLint enables/disables a set of extensions designed to allow as many files to parse as possible, but sometimes you'll need to enable an additional extension (e.g. Arrows), or disable some (e.g. MagicHash) to enable your code to parse.+HLint enables/disables a set of extensions designed to allow as many files to parse as possible, but sometimes you'll need to enable an additional extension (e.g. Arrows, QuasiQuotes, ...), or disable some (e.g. MagicHash) to enable your code to parse. +You can enable extensions by specifying additional command line arguments in [.hlint.yaml](#customizing-the-hints), e.g.: `- arguments: [-XQuasiQuotes]`.+ ## Customizing the hints To customize the hints given by HLint, create a file `.hlint.yaml` in the root of your project. For a suitable default run:@@ -326,7 +332,7 @@ ## Hacking HLint -Contributions to HLint are most welcome, following [my standard contribution guidelines](https://github.com/ndmitchell/neil/blob/master/README.md#contributions). You can run the tests either from within a `ghci` session by typing `:test` or by running the standalone binary's tests via `cabal run hlint test` or `stack init && stack run hlint test`.+Contributions to HLint are most welcome, following [my standard contribution guidelines](https://github.com/ndmitchell/neil/blob/master/README.md#contributions). You can run the tests either from within a `ghci` session by typing `:test` or by running the standalone binary's tests via `cabal run -- hlint --test` or `stack run -- hlint --test`. After changing hints, you will need to regenerate the [hints.md](hints.md) file with `hlint --generate-summary`. New tests for individual hints can be added directly to source and hint files by adding annotations bracketed in `<TEST></TEST>` code comment blocks. As some examples:
data/hlint.yaml view
@@ -230,7 +230,7 @@ - warn: {lhs: zipWith f y (repeat z), rhs: map (\x -> f x z) y} - warn: {lhs: listToMaybe (filter p x), rhs: find p x} - warn: {lhs: zip (take n x) (take n y), rhs: take n (zip x y)}- - warn: {lhs: zip (take n x) (take m y), rhs: take (min n m) (zip x y), side: notEq n m, note: IncreasesLaziness, name: Redundant take}+ - warn: {lhs: zip (take n x) (take m y), rhs: take (min n m) (zip x y), side: notEq n m, note: [IncreasesLaziness, DecreasesLaziness], name: Redundant take} # MONOIDS @@ -240,6 +240,8 @@ - warn: {lhs: x `mappend` mempty, rhs: x, name: "Monoid law, right identity"} - warn: {lhs: foldr (<>) mempty, rhs: mconcat} - warn: {lhs: foldr mappend mempty, rhs: mconcat}+ - warn: {lhs: mempty x, rhs: mempty, name: Evaluate}+ - warn: {lhs: x `mempty` y, rhs: mempty, name: Evaluate, note: "Make sure you didn't mean to use mappend instead of mempty"} # TRAVERSABLES @@ -421,7 +423,7 @@ - warn: {lhs: return =<< m, rhs: m, name: "Monad law, right identity"} - warn: {lhs: liftM, rhs: fmap} - warn: {lhs: liftA, rhs: fmap}- - hint: {lhs: m >>= return . f, rhs: f <$> m}+ - hint: {lhs: m >>= return . f, rhs: m Data.Functor.<&> f} - hint: {lhs: return . f =<< m, rhs: f <$> m} - warn: {lhs: fmap f x >>= g, rhs: x >>= g . f} - warn: {lhs: f <$> x >>= g, rhs: x >>= g . f}@@ -514,7 +516,7 @@ - warn: {lhs: fmap f (pure x), rhs: pure (f x)} - warn: {lhs: f <$> pure x, rhs: pure (f x)} - warn: {lhs: Just <$> a <|> pure Nothing, rhs: optional a}- - hint: {lhs: m >>= pure . f, rhs: f <$> m}+ - hint: {lhs: m >>= pure . f, rhs: m Data.Functor.<&> f} - hint: {lhs: pure . f =<< m, rhs: f <$> m} - warn: {lhs: empty <|> x, rhs: x, name: "Alternative law, left identity"} - warn: {lhs: x <|> empty, rhs: x, name: "Alternative law, right identity"}@@ -542,6 +544,8 @@ - warn: {lhs: fst (unzip x), rhs: map fst x} - warn: {lhs: snd (unzip x), rhs: map snd x}+ - hint: {lhs: "\\x y -> (x, y)", rhs: "(,)"}+ - hint: {lhs: "\\x y z -> (x, y, z)", rhs: "(,,)"} # MAYBE @@ -640,6 +644,9 @@ - hint: {lhs: mapM_ (writeChan a), rhs: writeList2Chan a} - error: {lhs: atomically (readTVar x), rhs: readTVarIO x}+ - error: {lhs: atomically (newTVar x), rhs: newTVarIO x}+ - error: {lhs: atomically (newTMVar x), rhs: newTMVarIO x}+ - error: {lhs: atomically newEmptyTMVar, rhs: newEmptyTMVarIO} # TYPEABLE @@ -857,6 +864,7 @@ - warn: {lhs: maybe False, rhs: any} - warn: {lhs: maybe True, rhs: all} - warn: {lhs: either (const mempty), rhs: foldMap}+ - warn: {lhs: either mempty, rhs: foldMap} - warn: {lhs: either (const False), rhs: any} - warn: {lhs: either (const True), rhs: all} - warn: {lhs: Data.Maybe.fromMaybe mempty, rhs: Data.Foldable.fold}@@ -877,6 +885,8 @@ - hint: {lhs: fromRight (pure ()), rhs: sequenceA_, note: IncreasesLaziness} - hint: {lhs: "[fst x, snd x]", rhs: Data.Bifoldable.biList x} - hint: {lhs: "\\(x, y) -> [x, y]", rhs: Data.Bifoldable.biList, note: IncreasesLaziness}+ - hint: {lhs: const mempty, rhs: mempty}+ - hint: {lhs: \x -> mempty, rhs: mempty, name: Redundant lambda} # hints that use the 'extra' library - group:@@ -978,7 +988,11 @@ - warn: {lhs: "pictures [ p ]", rhs: p, name: Evaluate} - warn: {lhs: "pictures [ p, q ]", rhs: p & q, name: Evaluate} - hint: {lhs: foldl1 (&), rhs: pictures}+ - hint: {lhs: foldl (&) blank, rhs: pictures}+ - hint: {lhs: foldl' (&) blank, rhs: pictures}+ - hint: {lhs: foldr' (&) blank, rhs: pictures} - hint: {lhs: foldr (&) blank, rhs: pictures}+ - hint: {lhs: foldr1 (&), rhs: pictures} - hint: {lhs: scaled x x, rhs: dilated x} - hint: {lhs: scaledPoint x x, rhs: dilatedPoint x} - warn: {lhs: "brighter (- a)", rhs: "duller a"}@@ -997,6 +1011,12 @@ - hint: {lhs: "not (x || y)", rhs: "not x && not y", name: Apply De Morgan law} - hint: {lhs: "not (x && y)", rhs: "not x || not y", name: Apply De Morgan law} - hint: {lhs: "[ f x | x <- l ]", rhs: map f l}+ - warn: {lhs: foldr f c (reverse x), rhs: foldl (flip f) c x, name: Use left fold instead of right fold}+ - warn: {lhs: foldr1 f (reverse x), rhs: foldl1 (flip f) x, name: Use left fold instead of right fold}+ - warn: {lhs: foldl f c (reverse x), rhs: foldr (flip f) c x, note: IncreasesLaziness, name: Use right fold instead of left fold}+ - warn: {lhs: foldl1 f (reverse x), rhs: foldr1 (flip f) x, note: IncreasesLaziness, name: Use right fold instead of left fold}+ - warn: {lhs: foldr' f c (reverse x), rhs: foldl' (flip f) c x, name: Use left fold instead of right fold}+ - warn: {lhs: foldl' f c (reverse x), rhs: foldr (flip f) c x, note: IncreasesLaziness, name: Use right fold instead of left fold} - group: # used for tests, enabled when testing this file@@ -1023,9 +1043,9 @@ # yes = not . (/= a) -- (== a) # yes = if a then 1 else if b then 1 else 2 -- if a || b then 1 else 2 # no = if a then 1 else if b then 3 else 2-# yes = a >>= return . bob -- bob <$> a+# yes = a >>= return . bob -- a Data.Functor.<&> bob # yes = return . bob =<< a -- bob <$> a-# yes = m alice >>= pure . b -- b <$> m alice+# yes = m alice >>= pure . b -- m alice Data.Functor.<&> b # yes = pure .b =<< m alice -- b <$> m alice # yes = asciiCI "hi" *> pure Hi -- asciiCI "hi" Data.Functor.$> Hi # yes = asciiCI "bye" *> return Bye -- asciiCI "bye" Data.Functor.$> Bye
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: hlint-version: 3.1.6+version: 3.2 license: BSD3 license-file: LICENSE category: Development@@ -27,7 +27,7 @@ extra-doc-files: README.md CHANGES.txt-tested-with: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5+tested-with: GHC==8.10, GHC==8.8, GHC==8.6 source-repository head type: git@@ -65,7 +65,7 @@ cpphs >= 1.20.1, cmdargs >= 0.10, uniplate >= 1.5,- ansi-terminal >= 0.6.2,+ ansi-terminal >= 0.8.1, extra >= 1.7.3, refact >= 0.3, aeson >= 1.1.2.0,@@ -80,7 +80,7 @@ build-depends: ghc-lib-parser == 8.10.* build-depends:- ghc-lib-parser-ex >= 8.10.0.14 && < 8.10.1+ ghc-lib-parser-ex >= 8.10.0.16 && < 8.10.1 if flag(gpl) build-depends: hscolour >= 1.21@@ -102,7 +102,6 @@ Paths_hlint Apply CmdLine- Grep Extension Fixity HLint@@ -115,6 +114,7 @@ Timing CC EmbedData+ Summary Config.Compute Config.Haskell Config.Read@@ -157,9 +157,6 @@ Test.All Test.Annotations Test.InputOutput- Test.Proof- Test.Summary- Test.Translate Test.Util
src/CmdLine.hs view
@@ -20,7 +20,7 @@ import DynFlags hiding (verbosity) import Language.Preprocessor.Cpphs-import System.Console.ANSI(hSupportsANSI)+import System.Console.ANSI(hSupportsANSIWithoutEmulation) import System.Console.CmdArgs.Explicit(helpText, HelpFormat(..)) import System.Console.CmdArgs.Implicit import System.Directory.Extra@@ -29,12 +29,12 @@ import System.FilePath import System.IO import System.IO.Error-import System.Info.Extra import System.Process import System.FilePattern import EmbedData import Util+import Timing import Extension import Paths_hlint import Data.Version@@ -47,10 +47,7 @@ automatic :: Cmd -> IO Cmd-automatic cmd = case cmd of- CmdMain{} -> dataDir =<< path =<< git =<< extension cmd- CmdGrep{} -> path =<< extension cmd- CmdTest{} -> dataDir cmd+automatic cmd = dataDir =<< path =<< git =<< extension cmd where path cmd = pure $ if null $ cmdPath cmd then cmd{cmdPath=["."]} else cmd extension cmd = pure $ if null $ cmdExtension cmd then cmd{cmdExtension=["hs","lhs"]} else cmd@@ -70,7 +67,8 @@ Just git -> do let args = ["ls-files", "--cached", "--others", "--exclude-standard"] ++ map ("*." ++) (cmdExtension cmd)- files <- readProcess git args ""+ files <- timedIO "Execute" (unwords $ git:args) $+ readProcess git args "" pure cmd{cmdFiles = cmdFiles cmd ++ lines files} | otherwise = pure cmd @@ -90,7 +88,7 @@ instance Default ColorMode where- def = if isWindows then Never else Auto+ def = Auto data Cmd@@ -127,29 +125,8 @@ ,cmdRefactorOptions :: String -- ^ Options to pass to the `refactor` executable. ,cmdWithRefactor :: FilePath -- ^ Path to refactor tool ,cmdIgnoreGlob :: [FilePattern]- }- | CmdGrep- {cmdFiles :: [FilePath] -- ^ which files to run it on, nothing = none given- ,cmdPattern :: String- ,cmdExtension :: [String] -- ^ extensions- ,cmdLanguage :: [String] -- ^ the extensions (may be prefixed by "No")- ,cmdPath :: [String]- ,cmdCppDefine :: [String]- ,cmdCppInclude :: [FilePath]- ,cmdCppFile :: [FilePath]- ,cmdCppSimple :: Bool- ,cmdCppAnsi :: Bool- }- | CmdTest- {cmdProof :: [FilePath] -- ^ a proof script to check against- ,cmdGivenHints :: [FilePath] -- ^ which settings files were explicitly given- ,cmdDataDir :: FilePath -- ^ the data directory- ,cmdReports :: [FilePath] -- ^ where to generate reports- ,cmdTempDir :: FilePath -- ^ temporary directory to put the files in- ,cmdQuickCheck :: Bool- ,cmdTypeCheck :: Bool- ,cmdWithRefactor :: FilePath- ,cmdGenerateSummary :: Bool -- ^ Generate a summary of built-in hints+ ,cmdGenerateSummary :: [FilePath] -- ^ Generate a summary of available hints+ ,cmdTest :: Bool } deriving (Data,Typeable,Show) @@ -160,7 +137,7 @@ ,cmdGivenHints = nam "hint" &= typFile &= help "Hint/ignore file to use" ,cmdWithGroups = nam_ "with-group" &= typ "GROUP" &= help "Extra hint groups to use" ,cmdGit = nam "git" &= help "Run on files tracked by git"- ,cmdColor = nam "colour" &= name "color" &= opt Always &= typ "always/never/auto" &= help "Color output (requires ANSI terminal; auto means on when $TERM is supported; by itself, selects always)"+ ,cmdColor = nam "colour" &= name "color" &= opt Always &= typ "always/never/auto" &= help "Color output (requires an ANSI terminal; 'auto' means on if the standard output channel can support ANSI; by itself, selects 'always')" ,cmdThreads = 1 &= name "threads" &= name "j" &= opt (0 :: Int) &= help "Number of threads to use (-j for all)" ,cmdIgnore = nam "ignore" &= typ "HINT" &= help "Ignore a particular hint" ,cmdShowAll = nam "show" &= help "Show all ignored ideas"@@ -187,18 +164,9 @@ ,cmdRefactorOptions = nam_ "refactor-options" &= typ "OPTIONS" &= help "Options to pass to the `refactor` executable" ,cmdWithRefactor = nam_ "with-refactor" &= help "Give the path to refactor" ,cmdIgnoreGlob = nam_ "ignore-glob" &= help "Ignore paths matching glob pattern"+ ,cmdGenerateSummary = nam_ "generate-summary" &= opt "hints.md" &= help "Generate a summary of built-in hints"+ ,cmdTest = nam_ "test" &= help "Run the test suite" } &= auto &= explicit &= name "lint"- ,CmdGrep- {cmdFiles = def &= args &= typ "FILE/DIR"- ,cmdPattern = def &= argPos 0 &= typ "PATTERN"- } &= explicit &= name "grep"- ,CmdTest- {cmdProof = nam_ "proof" &= typFile &= help "Isabelle/HOLCF theory file"- ,cmdTypeCheck = nam_ "typecheck" &= help "Use GHC to type check the hints"- ,cmdQuickCheck = nam_ "quickcheck" &= help "Use QuickCheck to check the hints"- ,cmdTempDir = nam_ "tempdir" &= help "Where to put temporary files (not cleaned up)"- ,cmdGenerateSummary = nam_ "generate-summary" &= help "Generate a summary of built-in hints"- } &= explicit &= name "test" &= details ["HLint gives hints on how to improve Haskell code." ,"" ,"To check all Haskell files in 'src' and generate a report type:"@@ -220,7 +188,7 @@ fail $ unlines $ "Failed to find requested hint files:" : map (" "++) bad -- if the user has given any explicit hints, ignore the local ones- implicit <- if explicit /= [] then pure Nothing else do+ implicit <- if explicit /= [] || cmdGenerateSummary cmd /= [] then pure Nothing else do -- we follow the stylish-haskell config file search policy -- 1) current directory or its ancestors; 2) home directory curdir <- getCurrentDirectory@@ -253,7 +221,9 @@ cmdUseColour cmd = case cmdColor cmd of Always -> pure True Never -> pure False- Auto -> hSupportsANSI stdout+ Auto -> do+ supportsANSI <- hSupportsANSIWithoutEmulation stdout+ pure $ Just True == supportsANSI "." <\> x = x@@ -286,7 +256,8 @@ getFile ignore (p:ath) exts t file = do isDir <- doesDirectoryExist $ p <\> file if isDir then do- let avoidDir x = let y = takeFileName x in "_" `isPrefixOf` y || ("." `isPrefixOf` y && not (all (== '.') y))+ let ignoredDirectories = ["dist", "dist-newstyle"]+ avoidDir x = let y = takeFileName x in "_" `isPrefixOf` y || ("." `isPrefixOf` y && not (all (== '.') y)) || y `elem` ignoredDirectories avoidFile x = let y = takeFileName x in "." `isPrefixOf` y || ignore x xs <- listFilesInside (pure . not . avoidDir) $ p <\> file pure [x | x <- xs, drop1 (takeExtension x) `elem` exts, not $ avoidFile x]@@ -328,7 +299,7 @@ f (a, e) ('N':'o':x) | Just x <- GhclibParserEx.readExtension x, let xs = expandDisable x = (deletes xs a, xs ++ deletes xs e) f (a, e) x | Just x <- GhclibParserEx.readExtension x = (x : delete x a, delete x e)- f (a, e) x = (a, e) -- Ignore unknown extension.+ f (a, e) x = error $ "Unknown extension: '" ++ x ++ "'" deletes [] ys = ys deletes (x:xs) ys = deletes xs $ delete x ys
src/Extension.hs view
@@ -25,8 +25,7 @@ , AlternativeLayoutRule -- Does not play well with 'MultiWayIf' , NegativeLiterals -- Was not enabled by HSE and enabling breaks tests. , StarIsType -- conflicts with TypeOperators. StarIsType is currently enabled by default,- -- so adding it here has no effect except avoiding passing it to apply-refact.- -- See https://github.com/mpickering/apply-refact/issues/58+ -- so adding it here has no effect, but it may not be the case in future GHC releases. ] -- | Extensions we turn on by default when parsing. Aim to parse as
src/GHC/All.hs view
@@ -9,6 +9,8 @@ parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode, ) where +import Control.Monad.Trans.Except+import Control.Monad.IO.Class import Util import Data.Char import Data.List.Extra@@ -152,50 +154,53 @@ -- 'defaultParseFlags'), the filename, and optionally the contents of -- that file. ----- Note that certain programs, e.g. @main = do@ successfully parse with GHC, but then--- fail with an error in the renamer. These programs will return a successful parse.+-- Note that certain programs, e.g. @main = do@ successfully parse+-- with GHC, but then fail with an error in the renamer. These+-- programs will return a successful parse. parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError ModuleEx)-parseModuleEx flags file str = timedIO "Parse" file $ do- str <- case str of- Just x -> pure x- Nothing | file == "-" -> getContentsUTF8- | otherwise -> readFileUTF8' file- str <- pure $ dropPrefix "\65279" str -- remove the BOM if it exists, see #130- ppstr <- runCpp (cppFlags flags) file str- let enableDisableExts = ghcExtensionsFromParseFlags flags- dynFlags <- parsePragmasIntoDynFlags baseDynFlags enableDisableExts file ppstr- case dynFlags of- Right ghcFlags -> do- ghcFlags <- pure $ lang_set ghcFlags $ baseLanguage flags- case fileToModule file ppstr ghcFlags of- POk s a -> do- let errs = bagToList . snd $ getMessages s ghcFlags- if not $ null errs then- handleParseFailure ghcFlags ppstr file str errs- else do- let anns =- ( Map.fromListWith (++) $ annotations s- , Map.fromList ((noSrcSpan, comment_q s) : annotations_comments s)- )- let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags- pure $ Right (ModuleEx (applyFixities fixes a) anns)- PFailed s ->- handleParseFailure ghcFlags ppstr file str $ bagToList . snd $ getMessages s ghcFlags- Left msg -> do- -- Parsing GHC flags from dynamic pragmas in the source- -- has failed. When this happens, it's reported by- -- exception. It's impossible or at least fiddly getting a- -- location so we skip that for now. Synthesize a parse- -- error.- let loc = mkSrcLoc (mkFastString file) (1 :: Int) (1 :: Int)- pure $ Left (ParseError (mkSrcSpan loc loc) msg ppstr)- where- handleParseFailure ghcFlags ppstr file str errs =- let errMsg = head errs- loc = errMsgSpan errMsg- doc = formatErrDoc ghcFlags (errMsgDoc errMsg)- in ghcFailOpParseModuleEx ppstr file str (loc, doc)+parseModuleEx flags file str = timedIO "Parse" file $ runExceptT $ do+ str <- case str of+ Just x -> pure x+ Nothing | file == "-" -> liftIO getContentsUTF8+ | otherwise -> liftIO $ readFileUTF8' file+ str <- pure $ dropPrefix "\65279" str -- Remove the BOM if it exists, see #130.+ let enableDisableExts = ghcExtensionsFromParseFlags flags+ -- Read pragmas for the first time.+ dynFlags <- withExceptT (parsePragmasErr str) $ ExceptT (parsePragmasIntoDynFlags baseDynFlags enableDisableExts file str)+ dynFlags <- pure $ lang_set dynFlags $ baseLanguage flags+ -- Avoid running cpp unless CPP is enabled, see #1075.+ str <- if not (xopt Cpp dynFlags) then pure str else liftIO $ runCpp (cppFlags flags) file str+ -- If we preprocessed the file, re-read the pragmas.+ dynFlags <- if not (xopt Cpp dynFlags) then pure dynFlags+ else withExceptT (parsePragmasErr str) $ ExceptT (parsePragmasIntoDynFlags baseDynFlags enableDisableExts file str)+ dynFlags <- pure $ lang_set dynFlags $ baseLanguage flags+ -- Done with pragmas. Proceed to parsing.+ case fileToModule file str dynFlags of+ POk s a -> do+ let errs = bagToList . snd $ getMessages s dynFlags+ if not $ null errs then+ ExceptT $ parseFailureErr dynFlags str file str errs+ else do+ let anns =+ ( Map.fromListWith (++) $ annotations s+ , Map.fromList ((noSrcSpan, comment_q s) : annotations_comments s)+ )+ let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags+ pure $ ModuleEx (applyFixities fixes a) anns+ PFailed s ->+ ExceptT $ parseFailureErr dynFlags str file str $ bagToList . snd $ getMessages s dynFlags+ where+ -- If parsing pragmas fails, synthesize a parse error from the+ -- error message.+ parsePragmasErr src msg =+ let loc = mkSrcLoc (mkFastString file) (1 :: Int) (1 :: Int)+ in ParseError (mkSrcSpan loc loc) msg src + parseFailureErr dynFlags ppstr file str errs =+ let errMsg = head errs+ loc = errMsgSpan errMsg+ doc = formatErrDoc dynFlags (errMsgDoc errMsg)+ in ghcFailOpParseModuleEx ppstr file str (loc, doc) -- | Given a line number, and some source code, put bird ticks around the appropriate bit. context :: Int -> String -> String
src/GHC/Util/HsExpr.hs view
@@ -34,7 +34,7 @@ import Data.List.Extra import Data.Tuple.Extra -import Refact (toSS)+import Refact (substVars, toSS) import Refact.Types hiding (SrcSpan, Match) import qualified Refact.Types as R (SrcSpan) @@ -214,7 +214,7 @@ factor _ = Nothing mkRefact :: [LHsExpr GhcPs] -> R.SrcSpan -> Refactoring R.SrcSpan mkRefact subts s =- let tempSubts = zipWith (\a b -> ([a], toSS b)) ['a' .. 'z'] subts+ let tempSubts = zipWith (\a b -> (a, toSS b)) substVars subts template = dotApps (map (strToVar . fst) tempSubts) in Replace Expr s tempSubts (unsafePrettyPrint template) -- Rewrite @\x y -> x + y@ as @(+)@.@@ -231,7 +231,7 @@ -- We're done factoring, but have no variables left, so we shouldn't make a lambda. -- @\ -> e@ ==> @e@-niceLambdaR [] e = (e, const [])+niceLambdaR [] e = (e, \s -> [Replace Expr s [("a", toSS e)] "a"]) -- Base case. Just a good old fashioned lambda. niceLambdaR ss e = let grhs = noLoc $ GRHS noExtField [] e :: LGRHS GhcPs (LHsExpr GhcPs)
src/GHC/Util/View.hs view
@@ -3,11 +3,12 @@ module GHC.Util.View ( fromParen , View(..)- , Var_(Var_), PVar_(PVar_), PApp_(PApp_), App2(App2),LamConst1(LamConst1)+ , RdrName_(RdrName_), Var_(Var_), PVar_(PVar_), PApp_(PApp_), App2(App2),LamConst1(LamConst1) , pattern SimpleLambda ) where import GHC.Hs+import RdrName import SrcLoc import BasicTypes import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader@@ -23,6 +24,7 @@ class View a b where view :: a -> b +data RdrName_ = NoRdrName_ | RdrName_ (Located RdrName) data Var_ = NoVar_ | Var_ String deriving Eq data PVar_ = NoPVar_ | PVar_ String data PApp_ = NoPApp_ | PApp_ String [LPat GhcPs]@@ -34,8 +36,12 @@ (GRHSs _ [L _ (GRHS _ [] x)] (L _ (EmptyLocalBinds _))))]) FromSource)))) = LamConst1 x view _ = NoLamConst1 +instance View (LHsExpr GhcPs) RdrName_ where+ view (fromParen -> (L _ (HsVar _ name))) = RdrName_ name+ view _ = NoRdrName_+ instance View (LHsExpr GhcPs) Var_ where- view (fromParen -> (L _ (HsVar _ (rdrNameStr -> x)))) = Var_ x+ view (view -> RdrName_ name) = Var_ (rdrNameStr name) view _ = NoVar_ instance View (LHsExpr GhcPs) App2 where
− src/Grep.hs
@@ -1,41 +0,0 @@--module Grep(runGrep) where--import Hint.All-import Apply-import Config.Type-import GHC.All-import Control.Monad-import Data.List-import Util-import Idea--import qualified GHC.Hs as GHC-import qualified BasicTypes as GHC-import qualified Outputable-import qualified ErrUtils-import Lexer-import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances-import SrcLoc as GHC hiding (mkSrcSpan)-import GHC.Util.DynFlags-import Bag--runGrep :: String -> ParseFlags -> [FilePath] -> IO ()-runGrep patt flags files = do- exp <- case parseExpGhcWithMode flags patt of- POk _ a -> pure a- PFailed ps -> exitMessage $- let (_, errs) = getMessages ps baseDynFlags- errMsg = head (bagToList errs)- msg = Outputable.showSDoc baseDynFlags $ ErrUtils.pprLocErrMsg errMsg- in "Failed to parse " ++ msg ++ ", when parsing:\n " ++ patt- let ghcUnit = GHC.noLoc $ GHC.ExplicitTuple GHC.noExtField [] GHC.Boxed- let rule = hintRules [HintRule Suggestion "grep" [] mempty (extendInstances exp) (extendInstances ghcUnit) Nothing]- forM_ files $ \file -> do- res <- parseModuleEx flags file Nothing- case res of- Left (ParseError sl msg ctxt) ->- print $ rawIdeaN Error (if "Parse error" `isPrefixOf` msg then msg else "Parse error: " ++ msg) sl ctxt Nothing []- Right m ->- forM_ (applyHints [] rule [m]) $ \i ->- print i{ideaHint="", ideaTo=Nothing}
src/HLint.hs view
@@ -12,6 +12,7 @@ import GHC.Util.DynFlags import Data.List.Extra import GHC.Conc+import System.Directory import System.Exit import System.IO.Extra import System.Time.Extra@@ -23,14 +24,13 @@ import Config.Type import Config.Compute import Report+import Summary import Idea import Apply import Test.All import Hint.All-import Grep import Refact import Timing-import Test.Proof import Parallel import GHC.All import CC@@ -51,44 +51,26 @@ -- on your server with untrusted input. hlint :: [String] -> IO [Idea] hlint args = do- initGlobalDynFlags+ startTimings cmd <- getCmd args- case cmd of- CmdMain{} -> do- startTimings- (time, xs) <- duration $ hlintMain args cmd- when (cmdTiming cmd) $ do- printTimings- putStrLn $ "Took " ++ showDuration time- pure $ if cmdNoExitCode cmd then [] else xs- CmdGrep{} -> hlintGrep cmd >> pure []- CmdTest{} -> hlintTest cmd >> pure []+ timedIO "Initialise" "global flags" initGlobalDynFlags+ if cmdTest cmd then+ hlintTest cmd >> pure []+ else do+ (time, xs) <- duration $ hlintMain args cmd+ when (cmdTiming cmd) $ do+ printTimings+ putStrLn $ "Took " ++ showDuration time+ pure $ if cmdNoExitCode cmd then [] else xs hlintTest :: Cmd -> IO ()-hlintTest cmd@CmdTest{..} =- if not $ null cmdProof then do- files <- cmdHintFiles cmd- s <- readFilesConfig files- let reps = if cmdReports == ["report.html"] then ["report.txt"] else cmdReports- mapM_ (proof reps s) cmdProof- else do- failed <- test cmd (\args -> do errs <- hlint args; unless (null errs) $ exitWith $ ExitFailure 1) cmdDataDir cmdGivenHints- when (failed > 0) exitFailure+hlintTest cmd@CmdMain{..} = do+ failed <- test cmd (\args -> do errs <- hlint args; unless (null errs) $ exitWith $ ExitFailure 1) cmdDataDir cmdGivenHints+ when (failed > 0) exitFailure cmdParseFlags :: Cmd -> ParseFlags cmdParseFlags cmd = parseFlagsSetLanguage (cmdExtensions cmd) $ defaultParseFlags{cppFlags=cmdCpp cmd} -hlintGrep :: Cmd -> IO ()-hlintGrep cmd@CmdGrep{..} =- if null cmdFiles then- exitWithHelp- else do- files <- concatMapM (resolveFile cmd Nothing) cmdFiles- if null files then- errorIO "No files found"- else- runGrep cmdPattern (cmdParseFlags cmd) files- withVerbosity :: Verbosity -> IO a -> IO a withVerbosity new act = do old <- getVerbosity@@ -106,6 +88,12 @@ ["- ignore: {name: " ++ show x ++ "}" | x <- bad] putStr $ unlines $ intercalate ["",""] $ group1:group2:groups pure []+ | cmdGenerateSummary /= [] = do+ forM_ cmdGenerateSummary $ \file -> timedIO "Summary" file $ do+ whenNormal $ putStrLn $ "Writing summary to " ++ file ++ " ..."+ summary <- generateSummary . snd =<< readAllSettings args cmd+ writeFileBinary file summary+ pure [] | null cmdFiles && not (null cmdFindHints) = do hints <- concatMapM (resolveFile cmd Nothing) cmdFindHints mapM_ (putStrLn . fst <=< computeSettings (cmdParseFlags cmd)) hints >> pure []@@ -123,11 +111,17 @@ resolveFiles :: Cmd -> Maybe FilePath -> IO Cmd resolveFiles cmd@CmdMain{..} tmpFile = do+ -- if the first file is named 'lint' and there is no 'lint' file+ -- then someone is probably invoking the older hlint multi-mode command+ -- so skip it+ cmdFiles <- if not $ ["lint"] `isPrefixOf` cmdFiles then pure cmdFiles else do+ b <- doesDirectoryExist "lint"+ pure $ if b then cmdFiles else drop1 cmdFiles+ files <- concatMapM (resolveFile cmd tmpFile) cmdFiles if null files then error "No files found" else pure cmd { cmdFiles = files }-resolveFiles cmd _ = pure cmd readAllSettings :: [String] -> Cmd -> IO (Cmd, [Setting]) readAllSettings args1 cmd@CmdMain{..} = do
src/Hint/Bracket.hs view
@@ -40,7 +40,7 @@ issue909 = foo (\((x : z) -> y) -> 9 + x * 7) -- \(x : z -> y) -> 9 + x * 7 issue909 = let ((x:: y) -> z) = q in q issue909 = do {((x :: y) -> z) <- e; return 1}-issue970 = (f x +) (g x) -- f x + (g x) @NoRefactor+issue970 = (f x +) (g x) -- f x + (g x) issue969 = (Just \x -> x || x) *> Just True -- type bracket reduction@@ -63,7 +63,7 @@ yes = operator foo $ operator -- operator foo operator no = operator foo $ operator bar yes = return $ Record{a=b}-no = f $ [1,2..5] -- f [1,2..5] @NoRefactor: apply-refact bug; see apply-refact #51+no = f $ [1,2..5] -- f [1,2..5] -- $/bracket rotation tests yes = (b $ c d) ++ e -- b (c d) ++ e@@ -250,10 +250,11 @@ , let y = noLoc (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs , let r = Replace Expr (toRefactSrcSpan locPar) [("a", toRefactSrcSpan locNoPar)] "a"] ++- [ suggest "Redundant section" x y []+ [ suggest "Redundant section" x 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 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"] splitInfix :: LHsExpr GhcPs -> [(LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)] splitInfix (L l (OpApp _ lhs op rhs)) =
src/Hint/Duplicate.hs view
@@ -7,16 +7,16 @@ <TEST> foo = a where {a = 1; b = 2; c = 3} \-bar = a where {a = 1; b = 2; c = 3} -- ??? @NoRefactor+bar = a where {a = 1; b = 2; c = 3} -- ??? main = do a; a; a; a-main = do a; a; a; a; a; a -- ??? @NoRefactor: refactoring not supported for duplication hints.-main = do a; a; a; a; a; a; a -- ??? @NoRefactor-main = do (do b; a; a; a); do (do c; a; a; a) -- ??? @NoRefactor-main = do a; a; a; b; a; a; a -- ??? @NoRefactor+main = do a; a; a; a; a; a -- ???+main = do a; a; a; a; a; a; a -- ???+main = do (do b; a; a; a); do (do c; a; a; a) -- ???+main = do a; a; a; b; a; a; a -- ??? main = do a; a; a; b; a; a-{-# ANN main "HLint: ignore Reduce duplication" #-}; main = do a; a; a; a; a; a -- @Ignore ??? @NoRefactor-{-# HLINT ignore main "Reduce duplication" #-}; main = do a; a; a; a; a; a -- @Ignore ??? @NoRefactor-{- HLINT ignore main "Reduce duplication" -}; main = do a; a; a; a; a; a -- @Ignore ??? @NoRefactor+{-# ANN main "HLint: ignore Reduce duplication" #-}; main = do a; a; a; a; a; a -- @Ignore ???+{-# HLINT ignore main "Reduce duplication" #-}; main = do a; a; a; a; a; a -- @Ignore ???+{- HLINT ignore main "Reduce duplication" -}; main = do a; a; a; a; a; a -- @Ignore ??? </TEST> -}
src/Hint/Export.hs view
@@ -3,10 +3,10 @@ <TEST> main = 1-module Foo where foo = 1 -- module Foo(module Foo) where @NoRefactor+module Foo where foo = 1 -- module Foo(module Foo) where module Foo(foo) where foo = 1-module Foo(module Foo) where foo = 1 -- @Ignore module Foo(...) where @NoRefactor-module Foo(module Foo, foo) where foo = 1 -- module Foo(..., foo) where @NoRefactor+module Foo(module Foo) where foo = 1 -- @Ignore module Foo(...) where+module Foo(module Foo, foo) where foo = 1 -- module Foo(..., foo) where </TEST> -} {-# LANGUAGE TypeFamilies #-}
src/Hint/Extensions.hs view
@@ -139,6 +139,8 @@ {-# LANGUAGE OverloadedStrings #-} \ main = id -- {-# LANGUAGE OverloadedLists #-} \+main = []+{-# LANGUAGE OverloadedLists #-} \ main = [1] {-# LANGUAGE OverloadedLists #-} \ main [1] = True@@ -216,13 +218,23 @@ import GHC.TypeLits(KnownNat, type (+), type (*)) {-# LANGUAGE LambdaCase, MultiWayIf, NoRebindableSyntax #-} \ foo = \case True -> 3 -- {-# LANGUAGE LambdaCase, NoRebindableSyntax #-}+{-# LANGUAGE ImportQualifiedPost #-} \+import Control.Monad qualified as CM+{-# LANGUAGE ImportQualifiedPost #-} \+import qualified Control.Monad as CM hiding (mapM) \+import Data.Foldable -- @NoRefactor: refactor only works when using GHC 8.10+{-# LANGUAGE StandaloneKindSignatures #-} \+type T :: (k -> Type) -> k -> Type \+data T m a = MkT (m a) (T Maybe (m a))+{-# LANGUAGE NoMonomorphismRestriction, NamedFieldPuns #-} \+main = 1 -- @Note Extension NamedFieldPuns is not used </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(..),toSS,ghcAnnotations,ghcModule) import Extension import Data.Generics.Uniplate.DataOnly@@ -261,8 +273,8 @@ (comment (mkLanguagePragmas sl exts)) (Just newPragma) ( [RequiresExtension (show gone) | (_, Just x) <- before \\ after, gone <- Map.findWithDefault [] x disappear] ++- [ Note $ "Extension " ++ show x ++ " is " ++ reason x- | (_, Just x) <- explainedRemovals])+ [ Note $ "Extension " ++ s ++ " is " ++ reason x+ | (s, Just x) <- explainedRemovals]) [ModifyComment (toSS (mkLanguagePragmas sl exts)) newPragma] | (L sl _, exts) <- languagePragmas $ pragmas (ghcAnnotations x) , let before = [(x, readExtension x) | x <- exts]@@ -432,6 +444,7 @@ used OverloadedLists = hasS isListExpr ||^ hasS isListPat where isListExpr :: HsExpr GhcPs -> Bool+ isListExpr (HsVar _ n) = rdrNameStr n == "[]" isListExpr ExplicitList{} = True isListExpr ArithSeq{} = True isListExpr _ = False@@ -453,6 +466,9 @@ f :: RdrName -> Bool f s = "#" `isSuffixOf` occNameStr s used PatternSynonyms = hasS isPatSynBind ||^ hasS isPatSynIE+used ImportQualifiedPost = hasS (== QualifiedPost)+used StandaloneKindSignatures = hasT (un :: StandaloneKindSig GhcPs)+ used _= const True hasDerive :: [String] -> Located (HsModule GhcPs) -> Bool
src/Hint/Lambda.hs view
@@ -28,20 +28,23 @@ f a = \x -> x + x where _ = test f (test -> a) = \x -> x + x f = \x -> x + x -- f x = x + x-fun x y z = f x y z -- fun = f @NoRefactor: refactoring for eta reduce is not implemented-fun x y z = f x x y z -- fun x = f x x @NoRefactor-fun x y z = f g z -- fun x y = f g @NoRefactor-fun x = f . g $ x -- fun = f . g @NoRefactor+fun x y z = f x y z -- fun = f+fun x y z = f x x y z -- fun x = f x x+fun x y z = f g z -- fun x y = f g+fun x = f . g $ x -- fun = f . g f = foo (\y -> g x . h $ y) -- g x . h f = foo (\y -> g x . h $ y) -- @Message Avoid lambda-f = foo ((*) x) -- (x *) @NoRefactor+f = foo ((*) x) -- (x *)+f = foo ((Prelude.*) x) -- (x Prelude.*) f = (*) x-f = foo (flip op x) -- (`op` x) @NoRefactor-f = foo (flip op x) -- @Message Use section @NoRefactor+f = foo (flip op x) -- (`op` x)+f = foo (flip op x) -- @Message Use section+f = foo (flip x y) -- (`x` y) foo x = bar (\ d -> search d table) -- (`search` table) foo x = bar (\ d -> search d table) -- @Message Avoid lambda using `infix` f = flip op x-f = foo (flip (*) x) -- (* x) @NoRefactor+f = foo (flip (*) x) -- (* x)+f = foo (flip (Prelude.*) x) -- (Prelude.* x) f = foo (flip (-) x) f = foo (\x y -> fun x y) -- @Warning fun f = foo (\x y z -> fun x y z) -- @Warning fun@@ -52,11 +55,11 @@ f = foo (\x -> \y -> x x y y) -- \x y -> x x y y f = foo (\x -> \x -> foo x x) -- \_ x -> foo x x f = foo (\(foo -> x) -> \y -> x x y y)-f = foo (\(x:xs) -> \x -> foo x x) -- \(_:xs) x -> foo x x @NoRefactor+f = foo (\(x:xs) -> \x -> foo x x) -- \(_:xs) x -> foo x x f = foo (\x -> \y -> \z -> x x y y z z) -- \x y z -> x x y y z z x ! y = fromJust $ lookup x y f = foo (\i -> writeIdea (getClass i) i)-f = bar (flip Foo.bar x) -- (`Foo.bar` x) @NoRefactor+f = bar (flip Foo.bar x) -- (`Foo.bar` x) f = a b (\x -> c x d) -- (`c` d) yes = \x -> a x where -- a yes = \x y -> op y x where -- flip op@@ -69,21 +72,21 @@ foo = [\column -> set column [treeViewColumnTitle := printf "%s (match %d)" name (length candidnates)]] foo = [\x -> x] foo = [\m x -> insert x x m]-foo a b c = bar (flux ++ quux) c where flux = a -- foo a b = bar (flux ++ quux) @NoRefactor+foo a b c = bar (flux ++ quux) c where flux = a -- foo a b = bar (flux ++ quux) foo a b c = bar (flux ++ quux) c where flux = c yes = foo (\x -> Just x) -- @Warning Just foo = bar (\x -> (x `f`)) -- f foo = bar (\x -> shakeRoot </> "src" </> x)-baz = bar (\x -> (x +)) -- (+) @NoRefactor+baz = bar (\x -> (x +)) -- (+) xs `withArgsFrom` args = f args-foo = bar (\x -> case x of Y z -> z) -- \(Y z) -> z @NoRefactor-yes = blah (\ x -> case x of A -> a; B -> b) -- \ case A -> a; B -> b @NoRefactor-yes = blah (\ x -> case x of A -> a; B -> b) -- @Note may require `{-# LANGUAGE LambdaCase #-}` adding to the top of the file @NoRefactor+foo = bar (\x -> case x of Y z -> z) -- \(Y z) -> z+yes = blah (\ x -> case x of A -> a; B -> b) -- \ case A -> a; B -> b+yes = blah (\ x -> case x of A -> a; B -> b) -- @Note may require `{-# LANGUAGE LambdaCase #-}` adding to the top of the file no = blah (\ x -> case x of A -> a x; B -> b x)-yes = blah (\ x -> (y, x)) -- (y,) @NoRefactor-yes = blah (\ x -> (y, x, z+q)) -- (y, , z+q) @NoRefactor-yes = blah (\ x -> (y, x, y, u, v)) -- (y, , y, u, v) @NoRefactor-yes = blah (\ x -> (y, x, z+q)) -- @Note may require `{-# LANGUAGE TupleSections #-}` adding to the top of the file @NoRefactor+yes = blah (\ x -> (y, x)) -- (y,)+yes = blah (\ x -> (y, x, z+q)) -- (y, , z+q)+yes = blah (\ x -> (y, x, y, u, v)) -- (y, , y, u, v)+yes = blah (\ x -> (y, x, z+q)) -- @Note may require `{-# LANGUAGE TupleSections #-}` adding to the top of the file yes = blah (\ x -> (y, x, z+x)) tmp = map (\ x -> runST $ action x) yes = map (\f -> dataDir </> f) dataFiles -- (dataDir </>)@@ -99,7 +102,7 @@ module Hint.Lambda(lambdaHint) where -import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, suggestN, ideaNote)+import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, suggestN, ideaNote, substVars) import Util import Data.List.Extra import Data.Set (Set)@@ -134,27 +137,29 @@ | L _ (EmptyLocalBinds noExtField) <- bind , isLambda $ fromParen origBody , null (universeBi pats :: [HsExpr GhcPs])- = [warn "Redundant lambda" o (gen pats origBody) [Replace Decl (toSS o) subts template]]- | length pats2 < length pats, pvars (drop (length pats2) pats) `disjoint` varss bind- = [warn "Eta reduce" (reform pats origBody) (reform pats2 bod2)- [ -- Disabled, see apply-refact #3+ = let (newPats, newBody) = fromLambda . lambda pats $ origBody+ (sub, tpl) = mkSubtsAndTpl newPats newBody+ gen :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs+ gen ps = uncurry reform . fromLambda . lambda ps+ in [warn "Redundant lambda" o (gen pats origBody) [Replace Decl (toSS o) sub tpl]]++ | let (newPats, newBody) = etaReduce pats origBody+ , length newPats < length pats, pvars (drop (length newPats) pats) `disjoint` varss bind+ = let (sub, tpl) = mkSubtsAndTpl newPats newBody+ in [warn "Eta reduce" (reform pats origBody) (reform newPats newBody)+ [Replace Decl (toSS $ reform pats origBody) sub tpl] ]- ] where reform :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs- reform ps b = L loc $ ValD noExtField $+ 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} - loc = combineSrcSpans loc1 loc2-- gen :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs- gen ps = uncurry reform . fromLambda . lambda ps+ mkSubtsAndTpl newPats newBody = (sub, tpl)+ where+ (origPats, vars) = mkOrigPats (Just (rdrNameStr funName)) newPats+ sub = ("body", toSS newBody) : zip vars (map toSS newPats)+ tpl = unsafePrettyPrint (reform origPats varBody) - (finalpats, body) = fromLambda . lambda pats $ origBody- (pats2, bod2) = etaReduce pats origBody- (origPats, subtsVars) = mkOrigPats (Just (rdrNameStr funName)) finalpats- subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) subtsVars (map toSS finalpats)- template = unsafePrettyPrint (reform origPats varBody) lambdaDecl _ = [] @@ -167,18 +172,29 @@ etaReduce ps (L loc (OpApp _ x (isDol -> True) y)) = etaReduce ps (L loc (HsApp noExtField x y)) etaReduce ps x = (ps, x) ---Section refactoring is not currently implemented. lambdaExp :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]-lambdaExp _ o@(L _ (HsPar _ (L _ (HsApp _ oper@(L _ (HsVar _ (L _ (rdrNameOcc -> f)))) y))))+lambdaExp _ o@(L _ (HsPar _ (L _ (HsApp _ oper@(L _ (HsVar _ origf@(L _ (rdrNameOcc -> f)))) y)))) | isSymOcc f -- is this an operator? , isAtom y , allowLeftSection $ occNameString f- , not $ isTypeApp y =- [suggestN "Use section" o $ noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField y oper]+ , not $ isTypeApp y+ = [suggest "Use section" o 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 ++ ")") -lambdaExp _ o@(L _ (HsPar _ (view -> App2 (view -> Var_ "flip") origf@(view -> Var_ f) y)))- | allowRightSection f, not $ "(" `isPrefixOf` f- = [suggestN "Use section" o $ noLoc $ HsPar noExtField $ noLoc $ SectionR noExtField origf y]+lambdaExp _ o@(L _ (HsPar _ (view -> App2 (view -> Var_ "flip") origf@(view -> RdrName_ f) y)))+ | allowRightSection (rdrNameStr f), not $ "(" `isPrefixOf` rdrNameStr f+ = [suggest "Use section" o to [r]]+ where+ to :: LHsExpr GhcPs+ to = noLoc $ HsPar noExtField $ noLoc $ SectionR noExtField origf y+ op = if isSymbolRdrName (unLoc f)+ then unsafePrettyPrint f+ else "`" ++ unsafePrettyPrint f ++ "`"+ var = if rdrNameStr f == "x" then "y" else "x"+ r = Replace Expr (toSS o) [(var, toSS y)] ("(" ++ op ++ " " ++ var ++ ")") lambdaExp p o@(L _ HsLam{}) | not $ any isOpApp p , (res, refact) <- niceLambdaR [] o@@ -187,8 +203,11 @@ , not $ "runST" `Set.member` Set.map occNameString (freeVars o) , let name = "Avoid lambda" ++ (if countRightSections res > countRightSections o then " using `infix`" else "") -- If the lambda's parent is an HsPar, and the result is also an HsPar, the span should include the parentheses.- , let from = case (p, res) of- (Just p@(L _ (HsPar _ (L _ HsLam{}))), L _ HsPar{}) -> p+ , let from = case p of+ -- Avoid creating redundant bracket.+ Just p@(L _ (HsPar _ (L _ HsLam{})))+ | 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)] where@@ -202,8 +221,8 @@ [suggest "Collapse lambdas" o (lambda pats body) [Replace Expr (toSS o) subts template]] where (pats, body) = fromLambda o- (oPats, subtsVars) = mkOrigPats Nothing pats- subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) subtsVars (map toSS pats)+ (oPats, vars) = mkOrigPats Nothing pats+ subts = ("body", toSS body) : zip vars (map toSS pats) template = unsafePrettyPrint (lambda oPats varBody) -- match a lambda with a variable pattern, with no guards and no where clauses@@ -274,22 +293,22 @@ -- | For each pattern, if it does not contain wildcards, replace it with a variable pattern. ----- The second component of the result is a list of substitution variables, which is ['a'..'z'],--- excluding variables that occur in the function name or patterns with wildcards. For example, given--- 'f (Foo a b _) = ...', 'f', 'a' and 'b' are removed.-mkOrigPats :: Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], [Char])-mkOrigPats funName pats = (zipWith munge subtsVars pats', subtsVars)+-- The second component of the result is a list of substitution variables, which are guaranteed+-- to not occur in the function name or patterns with wildcards. For example, given+-- 'f (Foo a b _) = ...', 'f', 'a' and 'b' are not usable as substitution variables.+mkOrigPats :: Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], [String])+mkOrigPats funName pats = (zipWith munge vars pats', vars) where (Set.unions -> used, pats') = unzip (map f pats) -- Remove variables that occur in the function name or patterns with wildcards- subtsVars = filter (\c -> c `Set.notMember` used && Just [c] /= funName) ['a'..'z']+ vars = filter (\s -> s `Set.notMember` used && Just s /= funName) substVars -- Returns (chars in the pattern if the pattern contains wildcards, (whether the pattern contains wildcards, the pattern))- f :: LPat GhcPs -> (Set Char, (Bool, LPat GhcPs))+ f :: LPat GhcPs -> (Set String, (Bool, LPat GhcPs)) f p | any isWildPat (universe p) =- let used = Set.fromList [c | (L _ (VarPat _ (rdrNameStr -> [c]))) <- universe p]+ let used = Set.fromList [rdrNameStr name | (L _ (VarPat _ name)) <- universe p] in (used, (True, p)) | otherwise = (mempty, (False, p)) @@ -297,6 +316,6 @@ isWildPat = \case (L _ (WildPat _)) -> True; _ -> False -- Replace the pattern with a variable pattern if the pattern doesn't contain wildcards.- munge :: Char -> (Bool, LPat GhcPs) -> LPat GhcPs+ 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 (L ploc $ mkRdrUnqual $ mkVarOcc ident))
src/Hint/List.hs view
@@ -45,7 +45,7 @@ import Data.Maybe import Prelude -import Hint.Type(DeclHint,Idea,suggest,ignore,toRefactSrcSpan,toSS)+import Hint.Type(DeclHint,Idea,suggest,ignore,substVars,toRefactSrcSpan,toSS) import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R@@ -196,14 +196,14 @@ ) . unzip )- . f True ['a'..'z']+ . f True substVars where f first _ x | patToStr x == "[]" = if first then Nothing else Just [] f first (ident:cs) (view -> PApp_ ":" [a, b]) = ((a, g ident a) :) <$> f False cs b f first _ _ = Nothing - g :: Char -> LPat GhcPs -> ((String, SrcSpan), LPat GhcPs)- g c (getLoc -> loc) = (([c], loc), noLoc $ VarPat noExtField (noLoc $ mkVarUnqual (fsLit [c])))+ g :: String -> LPat GhcPs -> ((String, SrcSpan), LPat GhcPs)+ g s (getLoc -> loc) = ((s, loc), noLoc $ VarPat noExtField (noLoc $ 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 =@@ -220,15 +220,15 @@ ) . unzip )- . f True ['a'..'z']+ . f True substVars where f first _ x | varToStr x == "[]" = if first then Nothing else Just [] f first (ident:cs) (view -> App2 c a b) | varToStr c == ":" = ((a, g ident a) :) <$> f False cs b f first _ _ = Nothing - g :: Char -> LHsExpr GhcPs -> (String, LHsExpr GhcPs)- g c p = ([c], L (getLoc p) (unLoc $ strToVar [c]))+ g :: String -> LHsExpr GhcPs -> (String, LHsExpr GhcPs)+ g s p = (s, L (getLoc p) (unLoc $ strToVar s)) useCons :: View a App2 => Bool -> a -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String) useCons False (view -> App2 op x y) | varToStr op == "++"
src/Hint/Monad.hs view
@@ -125,7 +125,8 @@ _ -> [] where f = monadNoResult (fromMaybe "" decl) id- seenVoid wrap x = monadNoResult (fromMaybe "" decl) wrap x ++ [warn "Redundant void" (wrap x) x [] | returnsUnit x]+ 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] doSpan doOrMDo = \case UnhelpfulSpan s -> UnhelpfulSpan s RealSrcSpan s ->@@ -204,14 +205,14 @@ monadStep wrap (o@(L loc (BindStmt _ p x _ _)) : rest) | isPWildcard p, returnsUnit x = let body = cL loc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr :: ExprLStmt GhcPs- in [warn "Redundant variable capture" o body []]+ in [warn "Redundant variable capture" o body [Replace Stmt (toSS o) [("x", toSS x)] "x"]] -- Redundant unit return : 'do <return ()>; return ()'. monadStep wrap o@[ L _ (BodyStmt _ x _ _)- , L _ (BodyStmt _ (fromRet -> Just (ret, L _ (HsVar _ (L _ unit)))) _ _)]+ , q@(L _ (BodyStmt _ (fromRet -> Just (ret, L _ (HsVar _ (L _ unit)))) _ _))] | returnsUnit x, occNameStr unit == "()"- = [warn ("Redundant " ++ ret) (wrap o) (wrap $ take 1 o) []]+ = [warn ("Redundant " ++ ret) (wrap o) (wrap $ take 1 o) [Delete Stmt (toSS q)]] -- Rewrite 'do x <- $1; return $ f $ g x' as 'f . g <$> x' monadStep wrap
src/Hint/Naming.hs view
@@ -16,24 +16,24 @@ <TEST> data Yes = Foo | Bar'Test-data Yes = Bar | Test_Bar -- data Yes = Bar | TestBar @NoRefactor+data Yes = Bar | Test_Bar -- data Yes = Bar | TestBar data No = a :::: b data Yes = Foo {bar_cap :: Int} data No = FOO | BarBAR | BarBBar-yes_foo = yes_foo + yes_foo -- yesFoo = ... @NoRefactor-yes_fooPattern Nothing = 0 -- yesFooPattern Nothing = ... @NoRefactor+yes_foo = yes_foo + yes_foo -- yesFoo = ...+yes_fooPattern Nothing = 0 -- yesFooPattern Nothing = ... no = 1 where yes_foo = 2 a -== b = 1 myTest = 1; my_test = 1 semiring'laws = 1-data Yes = FOO_A | Foo_B -- data Yes = FOO_A | FooB @NoRefactor+data Yes = FOO_A | Foo_B -- data Yes = FOO_A | FooB case_foo = 1 test_foo = 1-cast_foo = 1 -- castFoo = ... @NoRefactor+cast_foo = 1 -- castFoo = ... replicateM_ = 1 _foo__ = 1 section_1_1 = 1-runMutator# = 1 @NoRefactor+runMutator# = 1 foreign import ccall hexml_node_child :: IO () </TEST> -}
src/Hint/NewType.hs view
@@ -5,25 +5,25 @@ quantified data types because it is not valid. <TEST>-data Foo = Foo Int -- newtype Foo = Foo Int @NoRefactor: refactoring for "Use newtype" is not implemented-data Foo = Foo Int deriving (Show, Eq) -- newtype Foo = Foo Int deriving (Show, Eq) @NoRefactor-data Foo = Foo { field :: Int } deriving Show -- newtype Foo = Foo { field :: Int } deriving Show @NoRefactor-data Foo a b = Foo a -- newtype Foo a b = Foo a @NoRefactor+data Foo = Foo Int -- newtype Foo = Foo Int+data Foo = Foo Int deriving (Show, Eq) -- newtype Foo = Foo Int deriving (Show, Eq)+data Foo = Foo { field :: Int } deriving Show -- newtype Foo = Foo { field :: Int } deriving Show+data Foo a b = Foo a -- newtype Foo a b = Foo a data Foo = Foo { field1, field2 :: Int}-data S a = forall b . Show b => S b @NoRefactor: apply-refact 0.6 requires RankNTypes pragma+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) @NoRefactor+{-# LANGUAGE RankNTypes #-}; data Foo = Foo (forall a. a) -- newtype Foo = Foo (forall a. a) data Color a = Red a | Green a | Blue a data Pair a b = Pair a b data Foo = Bar data Foo a = Eq a => MkFoo a-data Foo a = () => Foo a -- newtype Foo a = Foo a @NoRefactor-data X = Y {-# UNPACK #-} !Int -- newtype X = Y Int @NoRefactor-data A = A {b :: !C} -- newtype A = A {b :: C} @NoRefactor-data A = A Int# @NoRefactor+data Foo a = () => Foo a -- newtype Foo a = Foo a+data X = Y {-# UNPACK #-} !Int -- newtype X = Y Int+data A = A {b :: !C} -- newtype A = A {b :: C}+data A = A Int# {-# LANGUAGE UnboxedTuples #-}; data WithAnn x = WithAnn (# Ann, x #) {-# LANGUAGE UnboxedTuples #-}; data WithAnn x = WithAnn {getWithAnn :: (# Ann, x #)}-data A = A () -- newtype A = A () @NoRefactor+data A = A () -- newtype A = A () newtype Foo = Foo Int deriving (Show, Eq) -- newtype Foo = Foo { getFoo :: Int } deriving (Show, Eq) -- newtype Foo = Foo Int deriving stock Show
src/Hint/Pattern.hs view
@@ -16,7 +16,7 @@ | c <- f b = c foo x = yes x x where yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e foo x | otherwise = y -- foo x = y-foo x = x + x where -- @NoRefactor: refactoring for "Redundant where" is not implemented+foo x = x + x where -- foo x | a = b | True = d -- foo x | a = b ; | otherwise = d foo (Bar _ _ _ _) = x -- Bar{} foo (Bar _ x _ _) = x@@ -25,7 +25,7 @@ foo = case v of v -> x -- x foo = case v of z -> z foo = case v of _ | False -> x-foo x | x < -2 * 3 = 4 @NoRefactor: ghc-exactprint bug; -2 becomes 2.+foo x | x < -2 * 3 = 4 foo = case v of !True -> x -- True {-# LANGUAGE BangPatterns #-}; foo = case v of !True -> x -- True {-# LANGUAGE BangPatterns #-}; foo = case v of !(Just x) -> x -- (Just x)@@ -42,7 +42,7 @@ {-# LANGUAGE BangPatterns #-}; foo = 1 where !False = True {-# LANGUAGE BangPatterns #-}; foo = 1 where g (Just !True) = Nothing -- True {-# LANGUAGE BangPatterns #-}; foo = 1 where Just !True = Nothing-foo otherwise = 1 -- _ @NoRefactor+foo otherwise = 1 -- _ foo ~x = y -- x {-# LANGUAGE Strict #-} foo ~x = y {-# LANGUAGE BangPatterns #-}; foo !(x, y) = x -- (x, y)@@ -228,7 +228,7 @@ f _ = False r = Replace R.Pattern (toSS o) [("x", toSS pat)] "x" patHint _ _ o@(L _ (AsPat _ v (L _ (WildPat _)))) =- [warn "Redundant as-pattern" o v []]+ [warn "Redundant as-pattern" o v [Replace R.Pattern (toSS o) [] (rdrNameStr v)]] patHint _ _ _ = [] expHint :: LHsExpr GhcPs -> [Idea]
src/Hint/Pragma.hs view
@@ -14,7 +14,7 @@ {-# OPTIONS -cpp #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_YHC -cpp #-} {-# OPTIONS_GHC -XFoo #-} -- {-# LANGUAGE Foo #-}-{-# OPTIONS_GHC -fglasgow-exts #-} -- ??? @NoRefactor+{-# OPTIONS_GHC -fglasgow-exts #-} -- ??? @NoRefactor: refactor output has one LANGUAGE pragma per extension, while hlint suggestion has a single LANGUAGE pragma {-# LANGUAGE RebindableSyntax, EmptyCase, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase #-} {-# LANGUAGE RebindableSyntax, EmptyCase, DuplicateRecordFields, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase, DuplicateRecordFields #-} {-# LANGUAGE RebindableSyntax #-}
src/Hint/Type.hs view
@@ -19,7 +19,7 @@ type CrossHint = [(Scope, ModuleEx)] -> [Idea] -- | Functions to generate hints, combined using the 'Monoid' instance.-data Hint {- PUBLIC -} = Hint+data Hint = Hint { hintModules :: [Setting] -> [(Scope, ModuleEx)] -> [Idea] -- ^ Given a list of modules (and their scope information) generate some 'Idea's. , hintModule :: [Setting] -> Scope -> ModuleEx -> [Idea] -- ^ Given a single module and its scope information generate some 'Idea's. , hintDecl :: [Setting] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]
src/Hint/Unsafe.hs view
@@ -3,15 +3,15 @@ Find things that are unsafe <TEST>-{-# NOINLINE slaves #-}; slaves = unsafePerformIO newIO-slaves = unsafePerformIO Multimap.newIO -- {-# NOINLINE slaves #-} ; slaves = unsafePerformIO Multimap.newIO-slaves = unsafePerformIO $ f y where foo = 1 -- {-# NOINLINE slaves #-} ; slaves = unsafePerformIO $ f y where foo = 1-slaves v = unsafePerformIO $ Multimap.newIO where foo = 1-slaves v = x where x = unsafePerformIO $ Multimap.newIO-slaves = x where x = unsafePerformIO $ Multimap.newIO -- {-# NOINLINE slaves #-} ; slaves = x where x = unsafePerformIO $ Multimap.newIO-slaves = unsafePerformIO . bar-slaves = unsafePerformIO . baz $ x -- {-# NOINLINE slaves #-} ; slaves = unsafePerformIO . baz $ x-slaves = unsafePerformIO . baz $ x -- {-# NOINLINE slaves #-} ; slaves = unsafePerformIO . baz $ x+{-# NOINLINE entries #-}; entries = unsafePerformIO newIO+entries = unsafePerformIO Multimap.newIO -- {-# NOINLINE entries #-} ; entries = unsafePerformIO Multimap.newIO+entries = unsafePerformIO $ f y where foo = 1 -- {-# NOINLINE entries #-} ; entries = unsafePerformIO $ f y where foo = 1+entries v = unsafePerformIO $ Multimap.newIO where foo = 1+entries v = x where x = unsafePerformIO $ Multimap.newIO+entries = x where x = unsafePerformIO $ Multimap.newIO -- {-# NOINLINE entries #-} ; entries = x where x = unsafePerformIO $ Multimap.newIO+entries = unsafePerformIO . bar+entries = unsafePerformIO . baz $ x -- {-# NOINLINE entries #-} ; entries = unsafePerformIO . baz $ x+entries = unsafePerformIO . baz $ x -- {-# NOINLINE entries #-} ; entries = unsafePerformIO . baz $ x </TEST> -}
src/Language/Haskell/HLint.hs view
@@ -32,12 +32,11 @@ import Config.Type import Config.Read-import Control.Exception.Extra import Idea import qualified Apply as H import HLint import Fixity-import FastString+import FastString ( unpackFS ) import GHC.All import Hint.All hiding (resolveHints) import qualified Hint.All as H@@ -78,17 +77,14 @@ -- Arguments which have no representation in the return type are silently ignored. argsSettings :: [String] -> IO (ParseFlags, [Classify], Hint) argsSettings args = do- cmd <- getCmd args- case cmd of- CmdMain{..} -> do- -- FIXME: One thing that could be supported (but isn't) is 'cmdGivenHints'- (_,settings) <- readAllSettings args cmd- let (fixities, classify, hints) = splitSettings settings- let flags = parseFlagsSetLanguage (cmdExtensions cmd) $ parseFlagsAddFixities fixities $- defaultParseFlags{cppFlags = cmdCpp cmd}- let ignore = [Classify Ignore x "" "" | x <- cmdIgnore]- pure (flags, classify ++ ignore, hints)- _ -> errorIO "Can only invoke autoSettingsArgs with the root process"+ cmd@CmdMain{..} <- getCmd args+ -- FIXME: One thing that could be supported (but isn't) is 'cmdGivenHints'+ (_,settings) <- readAllSettings args cmd+ let (fixities, classify, hints) = splitSettings settings+ let flags = parseFlagsSetLanguage (cmdExtensions cmd) $ parseFlagsAddFixities fixities $+ defaultParseFlags{cppFlags = cmdCpp cmd}+ let ignore = [Classify Ignore x "" "" | x <- cmdIgnore]+ pure (flags, classify ++ ignore, hints) -- | Given a directory (or 'Nothing' to imply 'getHLintDataDir'), and a module name
src/Refact.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE LambdaCase #-} module Refact- ( toRefactSrcSpan+ ( substVars+ , toRefactSrcSpan , toSS , checkRefactor, refactorPath, runRefactoring ) where@@ -11,6 +12,7 @@ import Data.Maybe import Data.Version.Extra import GHC.LanguageExtensions.Type+import System.Console.CmdArgs.Verbosity import System.Directory.Extra import System.Exit import System.IO.Extra@@ -19,6 +21,9 @@ import qualified SrcLoc as GHC +substVars :: [String]+substVars = [letter : number | number <- "" : map show [0..], letter <- ['a'..'z']]+ toRefactSrcSpan :: GHC.SrcSpan -> R.SrcSpan toRefactSrcSpan = \case GHC.RealSrcSpan span ->@@ -44,9 +49,9 @@ case mexc of Just exc -> do ver <- readVersion . tail <$> readProcess exc ["--version"] ""- pure $ if versionBranch ver >= [0,7,0,0]+ pure $ if ver >= minRefactorVersion then Right exc- else Left "Your version of refactor is too old, please upgrade to the latest version"+ else Left $ "Your version of refactor is too old, please upgrade to " ++ showVersion minRefactorVersion ++ " or later" Nothing -> pure $ Left $ unlines [ "Could not find 'refactor' executable" , "Tried to find '" ++ excPath ++ "' on the PATH"@@ -59,8 +64,12 @@ let args = [fin, "-v0"] ++ words opts ++ ["--refact-file", hints] ++ [arg | e <- enabled, arg <- ["-X", show e]] ++ [arg | e <- disabled, arg <- ["-X", "No" ++ show e]]+ whenLoud $ putStrLn $ "Running refactor: " ++ showCommandForUser rpath args (_, _, _, phand) <- createProcess $ proc rpath args try $ hSetBuffering stdin LineBuffering :: IO (Either IOException ()) hSetBuffering stdout LineBuffering -- Propagate the exit code from the spawn process waitForProcess phand++minRefactorVersion :: Version+minRefactorVersion = makeVersion [0,8,2,0]
+ src/Summary.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE RecordWildCards, TupleSections #-}++module Summary (generateSummary) where++import qualified Data.Map as Map+import Control.Monad.Extra+import System.FilePath+import Data.List.Extra+import System.Directory++import Idea+import Apply+import Hint.Type+import Hint.All+import Config.Type+import Test.Annotations+++data BuiltinKey = BuiltinKey+ { builtinName :: !String+ , builtinSeverity :: !Severity+ , builtinRefactoring :: !Bool+ } deriving (Eq, Ord)++data BuiltinValue = BuiltinValue+ { builtinInp :: !String+ , builtinFrom :: !String+ , builtinTo :: !(Maybe String)+ }+++dedupeBuiltin :: [(BuiltinKey, BuiltinValue)] -> [(BuiltinKey, BuiltinValue)]+dedupeBuiltin = Map.toAscList . Map.fromListWith (curry snd)+++-- | Generate a summary of hints, including built-in hints and YAML-configured hints+-- from @data/hlint.yaml@.+generateSummary :: [Setting] -> IO String+generateSummary settings = do+ -- Do not insert if the key already exists in the map. This has the effect+ -- of picking the first test case of a hint as the example in the summary.+ builtinHints <- mkBuiltinSummary+ let lhsRhsHints = [hint | SettingMatchExp hint <- settings]+ pure $ genBuiltinSummaryMd builtinHints lhsRhsHints++-- | The summary of built-in hints is generated by running the test cases in+-- @src/Hint/*.hs@. One entry per (hint name, severity, does it support refactoring).+mkBuiltinSummary :: IO [(String, [(BuiltinKey, BuiltinValue)])]+mkBuiltinSummary = forM builtinHints $ \(name, hint) -> (name,) <$> do+ let file = "src/Hint" </> name <.> "hs"+ b <- doesFileExist file+ if not b then do+ putStrLn $ "Couldn't find source hint file " ++ file ++ ", some hints will be missing"+ pure []+ else do+ tests <- parseTestFile file+ fmap dedupeBuiltin <$> concatForM tests $ \(TestCase _ _ inp _ _) -> do+ m <- parseModuleEx defaultParseFlags file (Just inp)+ pure $ case m of+ Right m -> map (ideaToValue inp) $ applyHints [] hint [m]+ Left _ -> []+ where+ ideaToValue :: String -> Idea -> (BuiltinKey, BuiltinValue)+ ideaToValue inp Idea{..} = (k, v)+ where+ -- make sure Windows/Linux don't differ on path separators+ to = fmap (\x -> if "Combine with " `isPrefixOf` x then replace "\\" "/" x else x) ideaTo+ k = BuiltinKey ideaHint ideaSeverity (notNull ideaRefactoring)+ v = BuiltinValue inp ideaFrom to+++genBuiltinSummaryMd :: [(String, [(BuiltinKey, BuiltinValue)])] -> [HintRule] -> String+genBuiltinSummaryMd builtins lhsRhs = unlines $+ [ "# Summary of Hints"+ , ""+ , "This page is auto-generated from `hlint --generate-summary`."+ ] +++ concat ["" : ("## Builtin " ++ group ) : "" : builtinTable hints | (group, hints) <- builtins] +++ [ ""+ , "## Configured hints"+ , ""+ ]+ ++ lhsRhsTable lhsRhs++row :: [String] -> [String]+row xs = ["<tr>"] ++ xs ++ ["</tr>"]++-- | Render using <code> if it is single-line, otherwise using <pre>.+haskell :: String -> [String]+haskell s+ | '\n' `elem` s = ["<pre>", s, "</pre>"]+ | otherwise = ["<code>", s, "</code>", "<br>"]++builtinTable :: [(BuiltinKey, BuiltinValue)] -> [String]+builtinTable builtins =+ ["<table>"]+ ++ row ["<th>Hint Name</th>", "<th>Hint</th>", "<th>Severity</th>"]+ ++ concatMap (uncurry showBuiltin) builtins+ ++ ["</table>"]++showBuiltin :: BuiltinKey -> BuiltinValue -> [String]+showBuiltin BuiltinKey{..} BuiltinValue{..} = row1+ where+ row1 = row $+ [ "<td>" ++ builtinName ++ "</td>"+ , "<td>"+ , "Example:"+ ]+ ++ haskell builtinInp+ ++ ["Found:"]+ ++ haskell builtinFrom+ ++ ["Suggestion:"]+ ++ haskell to+ ++ ["Does not support refactoring." | not builtinRefactoring]+ ++ ["</td>"] +++ [ "<td>" ++ show builtinSeverity ++ "</td>"+ ]+ to = case builtinTo of+ Nothing -> ""+ Just "" -> "Perhaps you should remove it."+ Just s -> s++lhsRhsTable :: [HintRule] -> [String]+lhsRhsTable hints =+ ["<table>"]+ ++ row ["<th>Hint Name</th>", "<th>Hint</th>", "<th>Severity</th>"]+ ++ concatMap showLhsRhs hints+ ++ ["</table>"]++showLhsRhs :: HintRule -> [String]+showLhsRhs HintRule{..} = row $+ [ "<td>" ++ hintRuleName ++ "</td>"+ , "<td>"+ , "LHS:"+ ]+ ++ haskell (show hintRuleLHS)+ ++ ["RHS:"]+ ++ haskell (show hintRuleRHS)+ +++ [ "</td>"+ , "<td>" ++ show hintRuleSeverity ++ "</td>"+ ]
src/Test/All.hs view
@@ -4,7 +4,6 @@ module Test.All(test) where import Control.Exception-import System.Console.CmdArgs import Control.Monad import Control.Monad.IO.Class import Data.Char@@ -24,18 +23,16 @@ import Hint.All import Test.Annotations import Test.InputOutput-import Test.Summary-import Test.Translate import Test.Util import System.IO.Extra import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable test :: Cmd -> ([String] -> IO ()) -> FilePath -> [FilePath] -> IO Int-test CmdTest{..} main dataDir files = do+test CmdMain{..} main dataDir files = do rpath <- refactorPath (if cmdWithRefactor == "" then Nothing else Just cmdWithRefactor) - (failures, (ideas, builtins)) <- withBuffering stdout NoBuffering $ withTests $ do+ (failures, ideas) <- withBuffering stdout NoBuffering $ withTests $ do hasSrc <- liftIO $ doesFileExist "hlint.cabal" let useSrc = hasSrc && null files testFiles <- if files /= [] then pure files else do@@ -59,16 +56,9 @@ wrap "Hint names" $ mapM_ (\x -> do progress; testNames $ snd x) testFiles wrap "Hint annotations" $ forM_ testFiles $ \(file,h) -> do progress; testAnnotations h file (eitherToMaybe rpath)- let hs = [h | (file, h) <- testFiles, takeFileName file /= "Test.hs"]- when cmdTypeCheck $ wrap "Hint typechecking" $- progress >> testTypeCheck cmdDataDir cmdTempDir hs- when cmdQuickCheck $ wrap "Hint QuickChecking" $- progress >> testQuickCheck cmdDataDir cmdTempDir hs when (null files && not hasSrc) $ liftIO $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped"- (,) <$> getIdeas <*> getBuiltins- whenLoud $ mapM_ print ideas- when cmdGenerateSummary $ writeFile "builtin.md" (genBuiltinSummaryMd builtins)+ case rpath of Left refactorNotFound -> putStrLn $ unlines [refactorNotFound, "Refactoring tests skipped"] _ -> pure ()
src/Test/Annotations.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP, PatternGuards, RecordWildCards, ViewPatterns #-} -- | Check the <TEST> annotations within source and hint files.-module Test.Annotations(testAnnotations) where+module Test.Annotations(testAnnotations, parseTestFile, TestCase(..)) where import Control.Exception.Extra import Control.Monad@@ -66,13 +66,6 @@ evaluate $ length $ show res pure res - when ("src/Hint" `isPrefixOf` file) $ mapM_ (mapM_ (addBuiltin inp)) ideas-- -- the hints from data/Test.hs are really fake hints we don't actually deploy- -- so don't record them- when (takeFileName file /= "Test.hs") $- either (const $ pure ()) addIdeas ideas- let good = case (out, ideas) of (Nothing, Right []) -> True (Just x, Right [idea]) | match x idea -> True@@ -165,34 +158,32 @@ testRefactor :: Maybe FilePath -> Maybe Idea -> String -> IO [String] -- Skip refactoring test if the refactor binary is not found. testRefactor Nothing _ _ = pure []--- Skip refactoring test if the hint has no suggestion (i.e., a parse error).+-- Skip refactoring test if there is no hint.+testRefactor _ Nothing _ = pure []+-- Skip refactoring test if the hint has no suggestion (such as "Parse error" or "Avoid restricted fuction"). testRefactor _ (Just idea) _ | isNothing (ideaTo idea) = pure []-testRefactor (Just rpath) midea inp = withTempFile $ \tempInp -> withTempFile $ \tempHints -> do- -- Note that we test the refactoring even if there are no suggestions,- -- as an extra test of apply-refact, on which we rely.- -- See https://github.com/ndmitchell/hlint/issues/958 for a discussion.- let refacts = map (show &&& ideaRefactoring) (maybeToList midea)- -- Ignores spaces and semicolons since apply-refact may change them.+-- Skip refactoring test if the hint does not support refactoring.+testRefactor _ (Just idea) _ | null (ideaRefactoring idea) = pure []+testRefactor (Just rpath) (Just idea) inp = withTempFile $ \tempInp -> withTempFile $ \tempHints -> do+ let refact = (show idea, ideaRefactoring idea)+ -- Ignores spaces and semicolons since unsafePrettyPrint may differ from apply-refact. process = filter (\c -> not (isSpace c) && c /= ';') matched expected g actual = process expected `g` process actual x `isProperSubsequenceOf` y = x /= y && x `isSubsequenceOf` y writeFile tempInp inp- writeFile tempHints (show refacts)+ writeFile tempHints (show [refact]) exitCode <- runRefactoring rpath tempInp tempHints defaultExtensions [] "--inplace" refactored <- readFile tempInp pure $ case exitCode of ExitFailure ec -> ["Refactoring failed: exit code " ++ show ec]- ExitSuccess -> case fmap ideaTo midea of- -- No hints. Refactoring should be a no-op.- Nothing | not (matched inp (==) refactored) ->- ["Expected refactor output: " ++ inp, "Actual: " ++ refactored]+ ExitSuccess -> case ideaTo idea of -- The hint's suggested replacement is @Just ""@, which means the hint -- suggests removing something from the input. The refactoring output -- should be a proper subsequence of the input.- Just (Just "") | not (matched refactored isProperSubsequenceOf inp) ->+ Just "" | not (matched refactored isProperSubsequenceOf inp) -> ["Refactor output is expected to be a proper subsequence of: " ++ inp, "Actual: " ++ refactored] -- The hint has a suggested replacement. The suggested replacement -- should be a substring of the refactoring output.- Just (Just to) | not (matched to isInfixOf refactored) ->+ Just to | not (matched to isInfixOf refactored) -> ["Refactor output is expected to contain: " ++ to, "Actual: " ++ refactored] _ -> []
− src/Test/Proof.hs
@@ -1,199 +0,0 @@---- | Check the coverage of the hints given a list of Isabelle theorems-module Test.Proof(proof) where--import Config.Type-import Control.Exception.Extra--proof :: [FilePath] -> [Setting] -> FilePath -> IO ()-proof _ _ _ = errorIO "Test.Proof is disabled."--{---import Data.Tuple.Extra-import Control.Applicative-import Control.Monad-import Control.Monad.Trans.State-import Language.Haskell.Exts.Util(paren, FreeVars, freeVars)-import qualified Data.Set as Set-import Data.Char-import Data.List.Extra-import Data.Maybe-import Data.Function-import System.FilePath-import Config.Type-import HSE.All-import Prelude---data Theorem = Theorem- {original :: Maybe HintRule- ,location :: String- ,lemma :: String- }--instance Eq Theorem where- t1 == t2 = lemma t1 == lemma t2--instance Ord Theorem where- compare t1 t2 = compare (lemma t1) (lemma t2)--instance Show Theorem where- show Theorem{..} = location ++ ":\n" ++ maybe "" f original ++ lemma ++ "\n"- where f HintRule{..} = "(* " ++ prettyPrint hintRuleLHS ++ " ==> " ++ prettyPrint hintRuleRHS ++ " *)\n"--proof :: [FilePath] -> [Setting] -> FilePath -> IO ()-proof reports hints thy = do- got <- isabelleTheorems (takeFileName thy) <$> readFile thy- let want = nubOrd $ hintTheorems hints- let unused = got \\ want- let missing = want \\ got- let reasons = map (\x -> (fst $ head x, map snd x)) $ groupBy ((==) `on` fst) $- sortBy (compare `on` fst) $ map (classifyMissing &&& id) missing- let summary = table $ let (*) = (,) in- ["HLint hints" * want- ,"HOL proofs" * got- ,"Useful proofs" * (got `intersect` want)- ,"Unused proofs" * unused- ,"Unproved hints" * missing] ++- [(" " ++ name) * ps | (name,ps) <- reasons]- putStr $ unlines summary- forM_ reports $ \report -> do- let out = ("Unused proofs",unused) : map (first ("Unproved hints - " ++)) reasons- writeFile report $ unlines $ summary ++ "" : concat- [("== " ++ a ++ " ==") : "" : map show b | (a,b) <- out]- putStrLn $ "Report written to " ++ report- where- table xs = [a ++ replicate (n + 6 - length a - length bb) ' ' ++ bb | (a,b) <- xs, let bb = show $ length b]- where n = maximum $ map (length . fst) xs---missingFuncs :: [(String, String)]-missingFuncs = let a*b = [(b,a) | b <- words b] in concat- ["IO" * "putChar putStr print putStrLn getLine getChar getContents hReady hPrint stdin"- ,"Exit" * "exitSuccess"- ,"Ord" * "(>) (<=) (>=) (<) compare minimum maximum sort sortBy"- ,"Show" * "show shows showIntAtBase"- ,"Read" * "reads read"- ,"String" * "lines unlines words unwords"- ,"Monad" * "mapM mapM_ sequence sequence_ msum mplus mzero liftM when unless return evaluate join void (>>=) (<=<) (>=>) forever ap"- ,"Functor" * "fmap"- ,"Numeric" * "(+) (*) fromInteger fromIntegral negate log (/) (-) (*) (^^) (^) subtract sqrt even odd"- ,"Char" * "isControl isPrint isUpper isLower isAlpha isDigit"- ,"Arrow" * "second first (***) (&&&)"- ,"Applicative+" * "traverse for traverse_ for_ pure (<|>) (<**>)"- ,"Exception" * "catch handle catchJust bracket error toException"- ,"WeakPtr" * "mkWeak"- ]----- | Guess why a theorem is missing-classifyMissing :: Theorem -> String-classifyMissing Theorem{original = Just HintRule{..}}- | _:_ <- [v :: Exp_ | v@Case{} <- universeBi (hintRuleLHS,hintRuleRHS)] = "case"- | _:_ <- [v :: Exp_ | v@ListComp{} <- universeBi (hintRuleLHS,hintRuleRHS)] = "list-comp"- | v:_ <- mapMaybe (`lookup` missingFuncs) [prettyPrint (v :: Name S) | v <- universeBi (hintRuleLHS,hintRuleRHS)] = v-classifyMissing _ = "?unknown"----- Extract theorems out of Isabelle code (HLint.thy)-isabelleTheorems :: FilePath -> String -> [Theorem]-isabelleTheorems file = find . lexer 1- where- find ((i,"lemma"):(_,'\"':lemma):rest) = Theorem Nothing (file ++ ":" ++ show i) lemma : find rest- find ((i,"lemma"):(_,name):(_,":"):(_,'\"':lemma):rest) = Theorem Nothing (file ++ ":" ++ show i) lemma : find rest- find ((i,"lemma"):(_,"assumes"):(_,'\"':assumes):(_,"shows"):(_,'\"':lemma):rest) =- Theorem Nothing (file ++ ":" ++ show i) (assumes ++ " \\<Longrightarrow> " ++ lemma) : find rest-- find ((i,"lemma"):rest) = Theorem Nothing (file ++ ":" ++ show i) "Unsupported lemma format" : find rest- find (x:xs) = find xs- find [] = []-- lexer i x- | i `seq` False = []- | Just x <- stripPrefix "(*" x, (a,b) <- breaks "*)" x = lexer (add a i) b- | Just x <- stripPrefix "\"" x, (a,b) <- breaks "\"" x = (i,'\"':a) : lexer (add a i) b -- NOTE: drop the final "- | x:xs <- x, isSpace x = lexer (add [x] i) xs- | (a@(_:_),b) <- span (\y -> y == '_' || isAlpha y) x = (i,a) : lexer (add a i) b- lexer i (x:xs) = (i,[x]) : lexer (add [x] i) xs- lexer i [] = []-- add s i = length (filter (== '\n') s) + i-- breaks s x | Just x <- stripPrefix s x = ("",x)- breaks s (x:xs) = let (a,b) = breaks s xs in (x:a,b)- breaks s [] = ([],[])---reparen :: Setting -> Setting-reparen (SettingMatchExp m@HintRule{..}) = SettingMatchExp m{hintRuleLHS = f False hintRuleLHS, hintRuleRHS = f True hintRuleRHS}- where f right x = if isLambda x || isIf x || badInfix x then Paren (ann x) x else x- badInfix (InfixApp _ _ op _) = prettyPrint op `elem` words "|| && ."- badInfix _ = False-reparen x = x----- Extract theorems out of the hints-hintTheorems :: [Setting] -> [Theorem]-hintTheorems xs =- [ Theorem (Just m) (loc $ ann hintRuleLHS) $ maybe "" assumes hintRuleSide ++ relationship hintRuleNotes a b- | SettingMatchExp m@HintRule{..} <- map reparen xs, let a = exp1 $ typeclasses hintRuleNotes hintRuleLHS, let b = exp1 hintRuleRHS, a /= b]- where- loc (SrcSpanInfo (SrcSpan file ln _ _ _) _) = takeFileName file ++ ":" ++ show ln-- subs xs = flip lookup [(reverse b, reverse a) | x <- words xs, let (a,'=':b) = break (== '=') $ reverse x]- funs = subs "id=ID not=neg or=the_or and=the_and (||)=tror (&&)=trand (++)=append (==)=eq (/=)=neq ($)=dollar"- ops = subs "||=orelse &&=andalso .=oo ===eq /==neq ++=++ !!=!! $=dollar $!=dollarBang"- pre = flip elem $ words "eq neq dollar dollarBang"- cons = subs "True=TT False=FF"-- typeclasses hintRuleNotes x = foldr f x hintRuleNotes- where- f (ValidInstance cls var) x = evalState (transformM g x) True- where g v@Var{} | v ~= var = do- b <- get; put False- pure $ if b then Paren an $ toNamed $ prettyPrint v ++ "::'a::" ++ cls ++ "_sym" else v- g v = pure v :: State Bool Exp_- f _ x = x-- relationship hintRuleNotes a b | any lazier hintRuleNotes = a ++ " \\<sqsubseteq> " ++ b- | DecreasesLaziness `elem` hintRuleNotes = b ++ " \\<sqsubseteq> " ++ a- | otherwise = a ++ " = " ++ b- where lazier IncreasesLaziness = True- lazier RemovesError{} = True- lazier _ = False-- assumes (App _ op var)- | op ~= "isNat" = "le\\<cdot>0\\<cdot>" ++ prettyPrint var ++ " \\<noteq> FF \\<Longrightarrow> "- | op ~= "isNegZero" = "gt\\<cdot>0\\<cdot>" ++ prettyPrint var ++ " \\<noteq> FF \\<Longrightarrow> "- assumes (App _ op var) | op ~= "isWHNF" = prettyPrint var ++ " \\<noteq> \\<bottom> \\<Longrightarrow> "- assumes _ = ""-- exp1 = exp . transformBi unqual-- -- Syntax translations- exp (App _ a b) = exp a ++ "\\<cdot>" ++ exp b- exp (Paren _ x) = "(" ++ exp x ++ ")"- exp (Var _ x) | Just x <- funs $ prettyPrint x = x- exp (Con _ (Special _ (TupleCon _ _ i))) = "\\<langle>" ++ replicate (i-1) ',' ++ "\\<rangle>"- exp (Con _ x) | Just x <- cons $ prettyPrint x = x- exp (Tuple _ _ xs) = "\\<langle>" ++ intercalate ", " (map exp xs) ++ "\\<rangle>"- exp (If _ a b c) = "If " ++ exp a ++ " then " ++ exp b ++ " else " ++ exp c- exp (Lambda _ xs y) = "\\<Lambda> " ++ unwords (map pat xs) ++ ". " ++ exp y- exp (InfixApp _ x op y) | Just op <- ops $ prettyPrint op =- if pre op then op ++ "\\<cdot>" ++ exp (paren x) ++ "\\<cdot>" ++ exp (paren y) else exp x ++ " " ++ op ++ " " ++ exp y-- -- Translations from the Haskell 2010 report- exp (InfixApp l a (QVarOp _ b) c) = exp $ App l (App l (Var l b) a) c -- S3.4- exp x@(LeftSection l e op) = let v = fresh x in exp $ Paren l $ Lambda l [toNamed v] $ InfixApp l e op (toNamed v) -- S3.5- exp x@(RightSection l op e) = let v = fresh x in exp $ Paren l $ Lambda l [toNamed v] $ InfixApp l (toNamed v) op e -- S3.5- exp x = prettyPrint x-- pat (PTuple _ _ xs) = "\\<langle>" ++ intercalate ", " (map pat xs) ++ "\\<rangle>"- pat x = prettyPrint x-- fresh x = head $ ("z":["v" ++ show i | i <- [1..]]) \\ vars x--vars :: FreeVars a => a -> [String]-vars = Set.toList . Set.map prettyPrint . freeVars--}
− src/Test/Summary.hs
@@ -1,58 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | Generate a markdown that summarizes the builtin hints.-module Test.Summary (genBuiltinSummaryMd) where--import qualified Data.Map as Map-import Config.Type-import Test.Util--genBuiltinSummaryMd :: BuiltinSummary -> String-genBuiltinSummaryMd builtins = unlines $- [ "# Built-in Hints"- , ""- , "This page is auto-generated from `cabal run hlint test -- --generate-summary`"- , "or `stack run hlint test -- --generate-summary`."- , ""- ]- ++ table builtins--table :: BuiltinSummary -> [String]-table builtins =- ["<table>"]- ++ row ["<th>Hint</th>", "<th>Severity</th>", "<th>Support Refactoring?</th>"]- ++ Map.foldMapWithKey showHint builtins- ++ ["</table>"]--row :: [String] -> [String]-row xs = ["<tr>"] ++ xs ++ ["</tr>"]---- | Render using <code> if it is single-line, otherwise using <pre>.-haskell :: String -> [String]-haskell s- | '\n' `elem` s = ["<pre>", s, "</pre>"]- | otherwise = ["<code>", s, "</code>", "<br>"]--showHint :: (String, Severity, Bool) -> BuiltinEx -> [String]-showHint (hint, sev, refact) BuiltinEx{..} = row1 ++ row2- where- row1 = row- [ "<td rowspan=2>" ++ hint ++ "</td>"- , "<td>" ++ show sev ++ "</td>"- , "<td>" ++ if refact then "Yes" else "No" ++ "</td>"- ]- row2 = row example- example =- [ "<td colspan=2>"- , "Example:"- ]- ++ haskell builtinInp- ++ ["Found:"]- ++ haskell builtinFrom- ++ ["Suggestion:"]- ++ haskell to- ++ ["</td>"]- to = case builtinTo of- Nothing -> ""- Just "" -> "Perhaps you should remove it."- Just s -> s
− src/Test/Translate.hs
@@ -1,127 +0,0 @@---- | Translate the hints to Haskell and run with GHC.-module Test.Translate(testTypeCheck, testQuickCheck) where--import Config.Type-import Control.Exception.Extra-import Control.Monad.IO.Class-import Test.Util--testTypeCheck :: FilePath -> FilePath -> [[Setting]] -> Test ()-testTypeCheck _ _ _ = liftIO $ errorIO "Test.Translate is disabled."---- | Given a set of hints, do all the HintRule hints satisfy QuickCheck-testQuickCheck :: FilePath -> FilePath -> [[Setting]] -> Test ()-testQuickCheck _ _ _ = liftIO $ errorIO "Test.Translate is disabled."--{--import Control.Monad-import Control.Monad.IO.Class-import Data.List.Extra-import System.IO.Extra-import Data.Maybe-import System.Process-import System.Exit-import System.FilePath-import Language.Haskell.Exts.Util(FreeVars, freeVars)-import qualified Data.Set as Set--import Config.Type-import HSE.All-import Test.Util---runMains :: FilePath -> FilePath -> [String] -> Test ()-runMains datadir tmpdir xs = do- res <- liftIO $ (if tmpdir == "" then withTempDir else ($ tmpdir)) $ \dir -> do- ms <- forM (zipFrom 1 xs) $ \(i,x) -> do- let m = "I" ++ show i- writeFile (dir </> m <.> "hs") $ replace "module Main" ("module " ++ m) x- pure m- writeFile (dir </> "Main.hs") $ unlines $- ["import qualified " ++ m | m <- ms] ++- ["main = do"] ++- [" " ++ m ++ ".main" | m <- ms]- system $ "runhaskell -i" ++ dir ++ " -i" ++ datadir ++ " Main"- replicateM_ (length xs) $ tested $ res == ExitSuccess----- | Given a set of hints, do all the HintRule hints type check-testTypeCheck :: FilePath -> FilePath -> [[Setting]] -> Test ()-testTypeCheck = wrap toTypeCheck---- | Given a set of hints, do all the HintRule hints satisfy QuickCheck-testQuickCheck :: FilePath -> FilePath -> [[Setting]] -> Test ()-testQuickCheck = wrap toQuickCheck--wrap :: ([HintRule] -> [String]) -> FilePath -> FilePath -> [[Setting]] -> Test ()-wrap f datadir tmpdir hints = runMains datadir tmpdir [unlines $ body [x | SettingMatchExp x <- xs] | xs <- hints]- where- body xs =- ["{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules, ScopedTypeVariables, DeriveDataTypeable #-}"- ,"{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-}"- ,"module Main(main) where"] ++- -- concat [map (prettyPrint . hackImport) $ scopeImports $ hintRuleScope x | x <- take 1 xs] ++- f xs-- {-- -- Hack around haskell98 not being compatible with base anymore- hackImport i@ImportDecl{importAs=Just a,importModule=b}- | prettyPrint b `elem` words "Maybe List Monad IO Char" = i{importAs=Just b,importModule=a}- hackImport i = i- -}--------------------------------------------------------------------------- TYPE CHECKING--toTypeCheck :: [HintRule] -> [String]-toTypeCheck hints =- ["import HLint_TypeCheck hiding(main)"- ,"main = pure ()"] ++- ["{-# LINE " ++ show (startLine $ ann rhs) ++ " " ++ show (fileName $ ann rhs) ++ " #-}\n" ++- prettyPrint (PatBind an (toNamed $ "test" ++ show i) bod Nothing)- | (i, HintRule _ _ lhs rhs side _notes _ghcScope _ghcLhs _ghcRhs _ghcSide) <- zipFrom 1 hints, "noTypeCheck" `notElem` vars (maybeToList side)- , let vs = map toNamed $ nubOrd $ filter isUnifyVar $ vars lhs ++ vars rhs- , let inner = InfixApp an (Paren an lhs) (toNamed "==>") (Paren an rhs)- , let bod = UnGuardedRhs an $ if null vs then inner else Lambda an vs inner]--------------------------------------------------------------------------- QUICKCHECK--toQuickCheck :: [HintRule] -> [String]-toQuickCheck hints =- ["import HLint_QuickCheck hiding(main)"- ,"default(Maybe Bool,Int,Dbl)"- ,prettyPrint $ PatBind an (toNamed "main") (UnGuardedRhs an $ toNamed "withMain" $$ Do an tests) Nothing]- where- str x = Lit an $ String an x (show x)- int x = Lit an $ Int an (toInteger x) (show x)- app = App an- a $$ b = InfixApp an a (toNamed "$") b- tests =- [ Qualifier an $- Let an (BDecls an [PatBind an (toNamed "t") (UnGuardedRhs an bod) Nothing]) $- (toNamed "test" `app` str (fileName $ ann rhs) `app` int (startLine $ ann rhs) `app`- str (prettyPrint lhs ++ " ==> " ++ prettyPrint rhs)) `app` toNamed "t"- | (i, HintRule _ _ lhs rhs side note _ghcScope _ghcLhs _ghcRhs _ghcSide) <- zipFrom 1 hints, "noQuickCheck" `notElem` vars (maybeToList side)- , let vs = map (restrict side) $ nubOrd $ filter isUnifyVar $ vars lhs ++ vars rhs- , let op = if any isRemovesError note then "?==>" else "==>"- , let inner = InfixApp an (Paren an lhs) (toNamed op) (Paren an rhs)- , let bod = if null vs then Paren an inner else Lambda an vs inner]-- restrict (Just side) v- | any (=~= App an (toNamed "isNegZero") (toNamed v)) (universe side) = PApp an (toNamed "NegZero") [toNamed v]- | any (=~= App an (toNamed "isNat") (toNamed v)) (universe side) = PApp an (toNamed "Nat") [toNamed v]- | any (=~= App an (toNamed "isCompare") (toNamed v)) (universe side) = PApp an (toNamed "Compare") [toNamed v]- restrict _ v = toNamed v---isRemovesError :: Note -> Bool-isRemovesError RemovesError{} = True-isRemovesError _ = False--vars :: FreeVars a => a -> [String]-vars = Set.toList . Set.map prettyPrint . freeVars--}
src/Test/Util.hs view
@@ -3,8 +3,6 @@ module Test.Util( Test, withTests, passed, failed, progress,- addIdeas, getIdeas,- BuiltinSummary, BuiltinEx(..), addBuiltin, getBuiltins, ) where import Idea@@ -12,25 +10,11 @@ import Control.Monad.Trans.Reader import Control.Monad.IO.Class import Data.IORef-import Data.List.Extra-import Data.Map (Map)-import qualified Data.Map.Strict as Map --- | A map from (hint name, hint severity, does hint support refactoring) to an example.-type BuiltinSummary = Map (String, Severity, Bool) BuiltinEx--data BuiltinEx = BuiltinEx- { builtinInp :: !String- , builtinFrom :: !String- , builtinTo :: !(Maybe String)- }- data S = S {failures :: !Int ,total :: !Int ,ideas :: [[Idea]]- ,builtinHints :: BuiltinSummary- -- ^ A summary of builtin hints } newtype Test a = Test (ReaderT (IORef S) IO a)@@ -39,7 +23,7 @@ -- | Returns the number of failing tests. withTests :: Test a -> IO (Int, a) withTests (Test act) = do- ref <- newIORef $ S 0 0 [] Map.empty+ ref <- newIORef $ S 0 0 [] res <- runReaderT act ref S{..} <- readIORef ref putStrLn ""@@ -47,31 +31,6 @@ then "Tests passed (" ++ show total ++ ")" else "Tests failed (" ++ show failures ++ " of " ++ show total ++ ")" pure (failures, res)--addIdeas :: [Idea] -> Test ()-addIdeas xs = do- ref <- Test ask- liftIO $ modifyIORef' ref $ \s -> s{ideas = xs : ideas s}--getIdeas :: Test [Idea]-getIdeas = do- ref <- Test ask- liftIO $ concat . reverse . ideas <$> readIORef ref--addBuiltin :: String -> Idea -> Test ()-addBuiltin inp idea@Idea{..} = unless ("Parse error" `isPrefixOf` ideaHint) $ do- ref <- Test ask- liftIO $ modifyIORef' ref $ \s ->- let k = (ideaHint, ideaSeverity, notNull ideaRefactoring)- v = BuiltinEx inp ideaFrom ideaTo- -- Do not insert if the key already exists in the map. This has the effect- -- of picking the first test case of a hint as the example in the summary.- in s{builtinHints = Map.insertWith (curry snd) k v (builtinHints s)}--getBuiltins :: Test BuiltinSummary-getBuiltins = do- ref <- Test ask- liftIO $ builtinHints <$> readIORef ref progress :: Test () progress = liftIO $ putChar '.'
src/Timing.hs view
@@ -14,6 +14,7 @@ import System.Console.CmdArgs.Verbosity import System.Time.Extra import System.IO.Unsafe+import System.IO type Category = String@@ -39,7 +40,9 @@ timedIO :: Category -> Item -> IO a -> IO a timedIO c i x = if not useTimings then x else do let quiet = c == "Hint"- unless quiet $ whenLoud $ putStr $ "Performing " ++ c ++ " of " ++ i ++ "... "+ unless quiet $ whenLoud $ do+ putStr $ "# " ++ c ++ " of " ++ i ++ "... "+ hFlush stdout (time, x) <- duration x atomicModifyIORef'_ timings $ Map.insertWith (+) (c, i) time unless quiet $ whenLoud $ putStrLn $ "took " ++ showDuration time