hlint-2.0.11/ 0000755 0000000 0000000 00000000000 13210071537 011076 5 ustar 00 0000000 0000000 hlint-2.0.11/Setup.hs 0000644 0000000 0000000 00000000056 13210071537 012533 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
hlint-2.0.11/README.md 0000644 0000000 0000000 00000050534 13210071537 012364 0 ustar 00 0000000 0000000 # HLint [](https://hackage.haskell.org/package/hlint) [](https://www.stackage.org/package/hlint) [](https://travis-ci.org/ndmitchell/hlint) [](https://ci.appveyor.com/project/ndmitchell/hlint)
HLint is a tool for suggesting possible improvements to Haskell code. These suggestions include ideas such as using alternative functions, simplifying code and spotting redundancies. You can try HLint online at [lpaste.net](http://lpaste.net/) - suggestions are shown at the bottom. This document is structured as follows:
* [Installing and running HLint](#installing-and-running-hlint)
* [FAQ](#faq)
* [Customizing the hints](#customizing-the-hints)
* [Hacking HLint](#hacking-hlint)
### Acknowledgements
This program has only been made possible by the presence of the [haskell-src-exts](https://github.com/haskell-suite/haskell-src-exts) package, and many improvements have been made by [Niklas Broberg](http://www.nbroberg.se) in response to feature requests. Additionally, many people have provided help and patches, including Lennart Augustsson, Malcolm Wallace, Henk-Jan van Tuyl, Gwern Branwen, Alex Ott, Andy Stewart, Roman Leshchinskiy, Johannes Lippmann, Iustin Pop, Steve Purcell, Mitchell Rosen and others.
### Bugs and limitations
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.
* 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.
* The `RebindableSyntax` extension can cause HLint to suggest incorrect changes.
* HLint turns on many language extensions so it can parse more documents, occasionally some break otherwise legal syntax - e.g. `{-#INLINE foo#-}` doesn't work with `MagicHash`. These extensions can be disabled with `-XNoMagicHash`.
## Installing and running HLint
Installation follows the standard pattern of any Haskell library or program: type `cabal update` to update your local hackage database, then `cabal install hlint` to install HLint.
Once HLint is installed, run `hlint source` where `source` is either a Haskell file, or a directory containing Haskell files. A directory will be searched recursively for any files ending with `.hs` or `.lhs`. For example, running HLint over darcs would give:
$ hlint darcs-2.1.2
darcs-2.1.2\src\CommandLine.lhs:94:1: Warning: Use concatMap
Found:
concat $ map escapeC s
Why not:
concatMap escapeC s
darcs-2.1.2\src\CommandLine.lhs:103:1: Suggestion: Use fewer brackets
Found:
ftable ++ (map (\ (c, x) -> (toUpper c, urlEncode x)) ftable)
Why not:
ftable ++ map (\ (c, x) -> (toUpper c, urlEncode x)) ftable
darcs-2.1.2\src\Darcs\Patch\Test.lhs:306:1: Warning: Use a more efficient monadic variant
Found:
mapM (delete_line (fn2fp f) line) old
Why not:
mapM_ (delete_line (fn2fp f) line) old
... lots more hints ...
Each hint says which file/line the hint relates to, how serious an issue it is, a description of the hint, what it found, and what you might want to replace it with. In the case of the first hint, it has suggested that instead of applying `concat` and `map` separately, it would be better to use the combination function `concatMap`.
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.
**Bug reports:** The suggested replacement should be equivalent - please report all incorrect suggestions not mentioned as known limitations.
### Running with Continuous Integration
Before running HLint on your continuous integration (CI) server, you should first ensure there are no existing hints. One way to achieve that is to ignore existing hints by running `hlint . --default > .hlint.yaml` and checking in the resulting `.hlint.yaml`.
On the CI you should then run `hlint .` (or `hlint src` if you only want to check the `src` directory). To avoid the cost of compilation you may wish to fetch the [latest HLint binary release](https://github.com/ndmitchell/hlint/releases/latest). For certain CI environments there are helper scripts to do that.
**Travis:** Execute the following command:
curl -sL https://raw.github.com/ndmitchell/hlint/master/misc/travis.sh | sh -s .
The arguments after `-s` are passed to `hlint`, so modify the final `.` if you want other arguments.
**Appveyor:** Add the following statement to `.appveyor.yml`:
- ps: Invoke-Command ([Scriptblock]::Create((Invoke-WebRequest 'https://raw.githubusercontent.com/ndmitchell/hlint/master/misc/appveyor.ps1').Content)) -ArgumentList @('.')
The arguments inside `@()` are passed to `hlint`, so add new arguments surrounded by `'`, space separated - e.g. `@('.' '--report')`.
### Integrations
HLint is integrated into lots of places:
* Lots of editors have HLint plugins (quite a few have more than one HLint plugin).
* HLint is part of the multiple editor plugins [ghc-mod](https://hackage.haskell.org/package/ghc-mod) and [Intero](https://github.com/commercialhaskell/intero).
* [Code Climate](https://docs.codeclimate.com/v1.0/docs/hlint) is a CI for analysis which integrates HLint.
* [Danger](http://allocinit.io/haskell/danger-and-hlint/) can be used to automatically comment on pull requests with HLint suggestions.
### Automatically Applying Hints
By supplying the `--refactor` flag hlint can automatically apply most
suggestions. Instead of a list of hints, hlint will instead output the
refactored file on stdout. In order to do this, it is necessary to have the
`refactor` executable on you path. `refactor` is provided by the
[`apply-refact`](https://github.com/mpickering/apply-refact) package,
it uses the GHC API in order to transform source files given a list of
refactorings to apply. Hlint directly calls the executable to apply the
suggestions.
Additional configuration can be passed to `refactor` with the
`--refactor-options` flag. Some useful flags include `-i` which replaces the
original file and `-s` which asks for confirmation before performing a hint.
An alternative location for `refactor` can be specified with the
`--with-refactor` flag.
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 provided.
There are no plans to support the duplication nor the renaming hints.
### Reports
HLint can generate a lot of information, making it difficult to search for particular types of errors. The `--report` flag will cause HLint to generate a report file in HTML, which can be viewed interactively. Reports are recommended when there are more than a handful of hints.
### Language Extensions
HLint enables most Haskell extensions, disabling only those which steal too much syntax (currently Arrows, TransformListComp, XmlSyntax and RegularPatterns). Individual extensions can be enabled or disabled with, for instance, `-XArrows`, or `-XNoMagicHash`. The flag `-XHaskell2010` selects Haskell 2010 compatibility.
### Emacs Integration
Emacs integration has been provided by [Alex Ott](http://xtalk.msk.su/~ott/). The integration is similar to compilation-mode, allowing navigation between errors. The script is at [hs-lint.el](https://raw.githubusercontent.com/ndmitchell/hlint/master/data/hs-lint.el), and a copy is installed locally in the data directory. To use, add the following code to the Emacs init file:
(require 'hs-lint)
(defun my-haskell-mode-hook ()
(local-set-key "\C-cl" 'hs-lint))
(add-hook 'haskell-mode-hook 'my-haskell-mode-hook)
### GHCi Integration
GHCi integration has been provided by Gwern Branwen. The integration allows running `:hlint` from the GHCi prompt. The script is at [hlint.ghci](https://raw.githubusercontent.com/ndmitchell/hlint/master/data/hlint.ghci), and a copy is installed locally in the data directory. To use, add the contents to your [GHCi startup file](https://www.haskell.org/ghc/docs/latest/html/users_guide/ghci.html#the-ghci-and-haskeline-files).
### Parallel Operation
To run HLint on 4 processors append the flags `-j4`. HLint will usually perform fastest if n is equal to the number of physical processors, which can be done with `-j` alone.
If your version of GHC does not support the GHC threaded runtime then install with the command: `cabal install --flags="-threaded"`
### C preprocessor support
HLint runs the [cpphs C preprocessor](http://hackage.haskell.org/package/cpphs) over all input files, by default using the current directory as the include path with no defined macros. These settings can be modified using the flags `--cpp-include` and `--cpp-define`. To disable the C preprocessor use the flag `-XNoCPP`. There are a number of limitations to the C preprocessor support:
* HLint will only check one branch of an `#if`, based on which macros have been defined.
* Any missing `#include` files will produce a warning on the console, but no information in the reports.
## FAQ
### Why are hints not applied recursively?
Consider:
foo xs = concat (map op xs)
This will suggest eta reduction to `concat . map op`, and then after making that change and running HLint again, will suggest use of `concatMap`. Many people wonder why HLint doesn't directly suggest `concatMap op`. There are a number of reasons:
* HLint aims to both improve code, and to teach the author better style. Doing modifications individually helps this process.
* Sometimes the steps are reasonably complex, by automatically composing them the user may become confused.
* Sometimes HLint gets transformations wrong. If suggestions are applied recursively, one error will cascade.
* Some people only make use of some of the suggestions. In the above example using concatMap is a good idea, but sometimes eta reduction isn't. By suggesting them separately, people can pick and choose.
* Sometimes a transformed expression will be large, and a further hint will apply to some small part of the result, which appears confusing.
* Consider `f $ (a b)`. There are two valid hints, either remove the $ or remove the brackets, but only one can be applied.
### Why doesn't the compiler automatically apply the optimisations?
HLint doesn't suggest optimisations, it suggests code improvements - the intention is to make the code simpler, rather than making the code perform faster. The [GHC compiler](http://haskell.org/ghc/) automatically applies many of the rules suggested by HLint, so HLint suggestions will rarely improve performance.
### 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, or passing them on the command line. For example, pass `--with=infixr 5 !@%$`, or put all the fixity declarations in a file and pass `--hint=fixities.hs`. You can also use [--find](https://rawgithub.com/ndmitchell/hlint/master/hlint.htm#find) to automatically produce a list of fixity declarations in a file.
### Which hints are used?
HLint uses the `hlint.yaml` file it ships with by default (containing things like the `concatMap` hint above), along with 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.
### Why do I sometimes get a "Note" with my hint?
Most hints are perfect substitutions, and these are displayed without any notes. However, some hints change the semantics of your program - typically in irrelevant ways - but HLint shows a warning note. HLint does not warn when assuming typeclass laws (such as `==` being symmetric). Some notes you may see include:
* __Increases laziness__ - for example `foldl (&&) True` suggests `and` including this note. The new code will work on infinite lists, while the old code would not. Increasing laziness is usually a good idea.
* __Decreases laziness__ - for example `(fst a, snd a)` suggests a including this note. On evaluation the new code will raise an error if a is an error, while the old code would produce a pair containing two error values. Only a small number of hints decrease laziness, and anyone relying on the laziness of the original code would be advised to include a comment.
* __Removes error__ - for example `foldr1 (&&)` suggests and including the note `Removes error on []`. The new code will produce `True` on the empty list, while the old code would raise an error. Unless you are relying on the exception thrown by the empty list, this hint is safe - and if you do rely on the exception, you would be advised to add a comment.
### What is the difference between error/warning/suggestion?
Every hint has a severity level:
* __Error__ - by default only used for parse errors.
* __Warning__ - for example `concat (map f x)` suggests `concatMap f x` as a "warning" severity hint. From a style point of view, you should always replace a combination of `concat` and `map` with `concatMap`.
* __Suggestion__ - for example `x !! 0` suggests `head x` as a "suggestion" severity hint. Typically `head` is a simpler way of expressing the first element of a list, especially if you are treating the list inductively. However, in the expression `f (x !! 4) (x !! 0) (x !! 7)`, replacing the middle argument with `head` makes it harder to follow the pattern, and is probably a bad idea. Suggestion hints are often worthwhile, but should not be applied blindly.
The difference between warning and suggestion is one of personal taste, typically my personal taste. If you already have a well developed sense of Haskell style, you should ignore the difference. If you are a beginner Haskell programmer you may wish to focus on warning hints before suggestion hints.
### Is it possible to use pragma annotations in code that is read by `ghci` (conflicts with `OverloadedStrings`)?
Short answer: yes, it is!
If the language extension `OverloadedStrings` is enabled, `ghci` may however report error messages such as:
```
Ambiguous type variable ‘t0’ arising from an annotation
prevents the constraint ‘(Data.Data.Data t0)’ from being solved.
```
In this case, a solution is to add the `:: String` type annotation. For example:
```
{-# ANN someFunc ("HLint: ignore Use fmap" :: String) #-}
```
See discussion in [issue #372](https://github.com/ndmitchell/hlint/issues/372).
## 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:
hlint --default > .hlint.yaml
This default configuration contains lots of examples, including:
* Adding command line arguments to all runs, e.g. `--color` or `-XNoMagicHash`.
* Ignoring certain hints, perhaps within certain modules/functions.
* Restricting use of GHC flags/extensions/functions, e.g. banning `Arrows` and `unsafePerformIO`.
* Adding additional project-specific hints.
You can see the output of `--default` [here](https://github.com/ndmitchell/hlint/blob/master/data/default.yaml).
### Ignoring hints
Some of the hints are subjective, and some users believe they should be ignored. Some hints are applicable usually, but occasionally don't always make sense. The ignoring mechanism provides features for suppressing certain hints. Ignore directives can either be written as pragmas in the file being analysed, or in the hint files. Examples of pragmas are:
* `{-# ANN module "HLint: ignore Eta reduce" #-}` - ignore all eta reduction suggestions in this module (use `module` literally, not the name of the module). Put this annotation _after_ the `import` statements.
* `{-# ANN myFunction "HLint: ignore" #-}` - don't give any hints in the function `myFunction`.
* `{-# ANN myFunction "HLint: error" #-}` - any hint in the function `myFunction` is an error.
* `{-# ANN module "HLint: error Use concatMap" #-}` - the hint to use `concatMap` is an error (you may also use `warn` or `suggest` in place of `error` for other severity levels).
If you have the `OverloadedStrings` extension enabled you will need to give an explicit type to the annotation, e.g. `{-# ANN myFunction ("HLint: ignore" :: String) #-}`.
Ignore directives can also be written in the hint files:
* `- ignore: {name: Eta reduce}` - suppress all eta reduction suggestions.
* `- ignore: {name: Eta reduce, within: [MyModule1, MyModule2]}` - suppress eta reduction hints in the `MyModule1` and `MyModule2` modules.
* `- ignore: {within: MyModule.myFunction}` - don't give any hints in the function `MyModule.myFunction`.
* `- error: {within: MyModule.myFunction}` - any hint in the function `MyModule.myFunction` is an error.
* `- error: {name: Use concatMap}` - the hint to use `concatMap` is an error (you may also use `warn` or `suggest` in place of `error` for other severity levels).
These directives are applied in the order they are given, with later hints overriding earlier ones.
### Adding hints
The hint suggesting `concatMap` can be defined as:
- warn: {lhs: concat (map f x), rhs: concatMap f x}
This line can be read as replace `concat (map f x)` with `concatMap f x`. All single-letter variables are treated as substitution parameters. For examples of more complex hints see the supplied `hlint.yaml` file in the data directory. This hint will automatically match `concat . map f` and `concat $ map f x`, so there is no need to give eta-reduced variants of the hints. Hints may tagged with `error`, `warn` or `suggest` to denote how severe they are by default. In addition, `hint` is a synonym for `suggest`. If you come up with interesting hints, please submit them for inclusion.
You can search for possible hints to add from a source file with the `--find` flag, for example:
$ hlint --find=src/Utils.hs
-- hints found in src/Util.hs
- warn: {lhs: "null (intersect a b)", rhs: "disjoint a b"}
- warn: {lhs: "dropWhile isSpace", rhs: "trimStart"}
- fixity: "infixr 5 !:"
These hints are suitable for inclusion in a custom hint file. You can also include Haskell fixity declarations in a hint file, and these will also be extracted. If you pass only `--find` flags then the hints will be written out, if you also pass files/folders to check, then the found hints will be automatically used when checking.
### More Advanced Hints
Hints can specify more advanced aspects, with names and side conditions. To see examples and descriptions of these features look at [the default hint file](https://github.com/ndmitchell/hlint/blob/master/data/hlint.yaml) and [the hint interpretation module comments](https://github.com/ndmitchell/hlint/blob/master/src/Hint/Match.hs).
## 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 `stack exec hlint test`.
New tests for individual hints can be added directly to source and hint files by adding annotations bracketed in `` code comment blocks. As some examples:
```haskell
{-
Tests to check the zipFrom hint works
zip [1..length x] x -- zipFrom 1 x
zip [1..length y] x
zip [1..length x] x -- ??? @Warning
-}
```
The general syntax is `lhs -- rhs` with `lhs` being the expression you expect to be rewritten as `rhs`. The absence of `rhs` means you expect no hints to fire. In addition `???` lets you assert a warning without a particular suggestion, while `@` tags require a specific severity -- both these features are used less commonly.
hlint-2.0.11/LICENSE 0000644 0000000 0000000 00000002764 13210071537 012114 0 ustar 00 0000000 0000000 Copyright Neil Mitchell 2006-2017.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Neil Mitchell nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
hlint-2.0.11/hlint.cabal 0000644 0000000 0000000 00000006065 13210071537 013207 0 ustar 00 0000000 0000000 cabal-version: >= 1.18
build-type: Simple
name: hlint
version: 2.0.11
license: BSD3
license-file: LICENSE
category: Development
author: Neil Mitchell
maintainer: Neil Mitchell
copyright: Neil Mitchell 2006-2017
synopsis: Source code suggestions
description:
HLint gives suggestions on how to improve your source code.
homepage: https://github.com/ndmitchell/hlint#readme
bug-reports: https://github.com/ndmitchell/hlint/issues
data-dir: data
data-files:
hlint.yaml
default.yaml
Test.hs
report_template.html
hs-lint.el
hlint.1
hlint.ghci
HLint_QuickCheck.hs
HLint_TypeCheck.hs
extra-doc-files:
README.md
CHANGES.txt
tested-with: GHC==8.2.1, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2
source-repository head
type: git
location: https://github.com/ndmitchell/hlint.git
flag threaded
default: True
manual: True
description: Build with support for multithreaded execution
flag gpl
default: True
manual: True
description: Use GPL libraries, specifically hscolour
library
default-language: Haskell2010
build-depends:
base == 4.*, process, filepath, directory, containers,
unordered-containers, yaml, vector, text, bytestring,
transformers, data-default,
cpphs >= 1.20.1,
cmdargs >= 0.10,
haskell-src-exts >= 1.18 && < 1.20,
haskell-src-exts-util >= 0.2.1.2,
uniplate >= 1.5,
ansi-terminal >= 0.6.2,
extra >= 1.4.9,
refact >= 0.3,
aeson >= 1.1.2.0
if flag(gpl)
build-depends: hscolour >= 1.21
else
cpp-options: -DGPL_SCARES_ME
hs-source-dirs: src
exposed-modules:
Language.Haskell.HLint
Language.Haskell.HLint3
other-modules:
Paths_hlint
Apply
CmdLine
Grep
HLint
HsColour
Idea
Report
Util
Parallel
Refact
CC
Config.Compute
Config.Haskell
Config.Read
Config.Type
Config.Yaml
HSE.All
HSE.Match
HSE.Reduce
HSE.Scope
HSE.Type
HSE.Unify
HSE.Util
Hint.All
Hint.Bracket
Hint.Comment
Hint.Duplicate
Hint.Export
Hint.Extensions
Hint.Import
Hint.Lambda
Hint.List
Hint.ListRec
Hint.Match
Hint.Monad
Hint.Naming
Hint.NewType
Hint.Pattern
Hint.Pragma
Hint.Restrict
Hint.Type
Hint.Unsafe
Hint.Util
Test.All
Test.Annotations
Test.InputOutput
Test.Proof
Test.Translate
Test.Util
executable hlint
default-language: Haskell2010
build-depends: base, hlint
main-is: src/Main.hs
ghc-options: -rtsopts
if flag(threaded)
ghc-options: -threaded
hlint-2.0.11/CHANGES.txt 0000644 0000000 0000000 00000062247 13210071537 012722 0 ustar 00 0000000 0000000 Changelog for HLint
2.0.11
#411, parse the YAML file with lots of HSE extensions turned on
#408, use the same config file logic in argsSettings as in hlint
Don't use unexported type synonyms in the public API
#405, fix false positives on MagicHash due to unboxed literals
2.0.10
#377, suggest lambda case
Add CodeClimate support
#378, suggest map for degenerate foldr
#395, suggest x $> y from x *> pure y and x *> return y
#395, suggest x <$ y from pure x <* y and return x <* y
#393, suggest f <$> m from m >>= pure . f and pure . f =<<
#366, avoid the github API for prebuilt hlint, is rate limited
#352, suggest maybe for fromMaybe d (f <$> x)
#338, warn about things imported hidden but not used
#337, add --git flag to additionally check files in git
#353, suggest _ <- mapM to mapM_
#357, warn on unnecessary use of MagicHash
2.0.9
#346, don't suggest explicit export lists
#344, fix the API so it works with hlint.yaml by default
2.0.8
#342, add back support for - to mean stdin
2.0.7
#340, fix for directory arguments in the .hlint.yaml
2.0.6
Do statements are not redundant if they change an operator parse
#333, simplify labels on Parse error, makes it easier to ignore
2.0.5
If the datadir is missing use data/ relative to the executable
Fix test mode to obey --datadir
2.0.4
--default adds ignores for any warnings it finds
2.0.3
#312, suggest removing the DeriveAnyClass extension
Suggest removing the DeriveLift extension
Remove redundant parts from list comprehensions, e.g. [a | True]
#326, fix up the bounds on the eta-reduce hint
2.0.2
#323, try and avoid malformatted JSON
#324, use `backticks` in notes
#324, remove double escaping in note for --json
#322, fix the YAML syntax in default.yaml
2.0.1
#320, still read ./HLint.hs if it exists
2.0
#319, add a hint \x -> f <$> g x ==> fmap f . g
Don't say how many hints were ignored
Add a --default flag
#314, allow arguments in YAML configuration files
Add maybe False (== x) ==> (== Just x) hint, plus for /=
Remove the ability to pass the file on stdin using - as the file
Remove encoding from ParseFlags
Remove the --encoding/--utf8 options, always use UTF8
#311, suggest writeFile instead of withFile/hPutStr
#288, add configurable restrictions
Suggest using an export list on modules
Look for nearby .hlint.yaml files to supply configuration
Support YAML configuration files
#308, don't suggest newtype for unboxed types
Remove the import "hint" feature for hint inclusion
Builtin hints do not need to be imported, can only be ignored
Delete HLint2 API
#290, add hints suggesting traverse/traverse_
#303, detect unused OverloadedStrings extension
#302, detect unused TupleSections extension
1.9.41
#299, warn in some cases when NumDecimals extension is unused
#300, warn when LambdaCase extension is unused
#301, when suggesting newtype remove strictness annotations
#297, better testing that there isn't a performance regression
#167, add -j flag for number of threads
#292, add fst/snd . unzip ==> map fst/snd
Don't suggest module export trick, breaks Haddock
1.9.40
#293, fix the JSON format of the output
1.9.39
#287, don't incorrectly suggest newtype
1.9.38
#279, suggest newtype instead of data
#262, add rules to detect redundant castPtr calls
Detect unused TypeApplications extension
#277, don't enable TypeApplications extension by default
Allow haskell-src-exts-1.19
#276, remove multiple redundant parens in one go
#160, add a --only CLI option
#237, fix incorrect quasi quotes extension warning
#257, better bang pattern hints
1.9.37
#255, don't suggest id @Int ==> @Int
#252, avoid clashes with GHCJS in the interim
1.9.36
Require haskell-src-exts-1.18
#249, suggest avoiding elem on singletons
1.9.35
#245, fix parse error reports
#243, update hlint.ghci to work with modern GHC
Require extra-1.4.9
1.9.34
#154, fix some incorrect line numbers in literate Haskell
#161, fix literate Haskell and CPP
1.9.33
#240, remove type-incorrect "on" hint
#234, warn about join seq
#232, suggest <|> instead of mplus in a few cases
1.9.32
#53, require cpphs-1.20.1, has important fixes
#224, treat select $ specially, as per esqueleto conventions
#231, don't modify qualification on substitutions
#229, add void/mapM_/forM_ hints
1.9.31
#222, don't suggest removing ~ if the Strict extension is on
1.9.30
#220, fix incorrect hints of foldr/foldl on a tuple accumulator
1.9.29
#219, add warnings about foldable methods on tuple
Put warnings before suggestions in the HTML report
1.9.28
#215, spot newtype deriving inside classes
1.9.27
#203, avoid recompiling everything twice
#213, don't suggest removing bang patterns on let
Rename HintStructure to HintPattern
#208, add an hlint function to the HLint3 API
#1, warn about unused DefaultSignatures extension
#137, add -XHaskell2010 and fix -XHaskell98
Allow checking even if a function has different arities
#193, don't warn on a -> (b -> c), it's sometimes sensible
#182, make parse errors severity Error
#181, warn on otherwise in a pattern variable
#163, eta reduce fun x = f $ x
#132, don't ever suggest liftM
#99, downgrade built in hints, Error => Warning => Suggestion
#99, add a Suggestion level severity
#207, make sure you close file handles
#205, add hint compare x y == EQ and /=
#204, add hint concatMap id ==> concat
#202, include refactorings is --json output
1.9.26
#200, fix all lint warnings
#143, expose argsSettings
1.9.25
#192, fix stdin output and --refactor
1.9.24
#188, improve spotting redundant brackets around patterns
#138, reenable redundant where hint
1.9.23
#184, require haskell-src-exts-1.17
#183, allow test_ as a prefix
1.9.22
Don't suggest redundant lambda on view patterns
Add --no-exit-code flag
#174, don't suggest string literals
#175, disable 'rec' stealing extensions by default
#170, add hints for eta-reduced operators
#149, integrate a --refactor flag
#147, fix the -fglasgow-exts hint
#140, better name for moving brackets to eliminate $
Extra hints for <$>
Remove a redundant fmap hint
#131, add =<< rules in addition to >>=
1.9.21
#130, ignore a BOM if it exists
#128, don't find files starting with . when searching directories
Suggest concat even if the [] is written ""
1.9.20
#122, fix the zipWith/repeat hint
1.9.19
#119, don't remove RecursiveDo if they use the rec statement
Add a suggestion concatMap/map ==> concatMap
1.9.18
More GHC 7.10 warnings and build support
1.9.17
#116, support hscolour-1.21
1.9.16
#108, make "hlint ." work again
1.9.15
#106, avoid warnings with GHC 7.10
#105, build with GHC 7.10
1.9.14
#649, don't suggest const for values using RecordWildCards
1.9.13
#97, remove the encoding bits of the API
#98, add an HLint3 prototype API
#93, make the --quickcheck tests work on GHC 7.8
Add --tempdir flag to the test mode
1.9.12
#96, fix the --utf8 flag
Make Encoding an alias for TextEncoding
Default to UTF8 encoding
1.9.11
#95, don't suggest camel case for names containing digits
Add a dependency on the extra package
#92, use a new way for determining the color default
Add a dependency on ansi-terminal
1.9.10
Spot unsafePerformIO without NOINLINE
1.9.9
#89, fix compiling the executable with --flag=-gpl
1.9.8
#82, don't crash on XmlHybrid modules
#88, allow avoiding HsColour, as it is GPL licensed
#87, don't push if down, since it can be type incorrect
1.9.7
#86, don't use color unless $TERM claims to support it
1.9.6
#85, fix the free variable matching check for lambda
#84, suggest fmap for Either
Make --json put each hint on a different line
Support -X for extensions to the hse mode
1.9.5
Remove support for GHC 7.2
Upgrade to haskell-src-exts-1.16
1.9.4
#81, fixes for GHC 7.9
#78, add hints for list patterns
#72, make --color the default on Linux
1.9.3
#73, fix multithreading and exceptions
1.9.2
#68, add --no-summary
1.9.1
#65, add flip (>>=) ==> (=<<) and the reverse
#61, add --json flag
1.9
Remove not (isControl x) ==> isPrint (not true for '\173')
#57, warn on invalid pragmas
Make the API pass and require comments
#59, make sure qualified operators match properly
Rename notTypeSafe annotation to noTypeCheck
Remove an invalid rule suggesting tanh
#13, add a --quickcheck flag to test the hints
Add --typecheck flag to test mode to type check the hints
Remove incorrect for intercalate to unlines
#37, remove incorrect hint for isAlphaNum
#45, add mapMaybe id ==> catMaybes
#42, add some repeat hints
1.8.61
#40, allow haskell-src-exts-1.15
Don't detect redundant Generics extension
1.8.60
#33, add --cpp-file to preinclude a file
#34, add back --quiet flag
#639, don't suggest evaluate, because not all Monad's are IO
#31, delete the elem/notElem hints
#30, remove weird "free module" matching
#15, add prototype grep mode
Change to make test a separate mode
#12, more list based suggestions
#637, turn off QuasiQuotes by default
1.8.59
#27, fix up directory file searching
1.8.58
Move the API to Language.Haskell.HLint2
#638, ensure $! doesn't break strictness with strict fields
#24, don't remove DeriveFunctor even when only on a newtype
#22, turn off UnboxedTuples by default
#21, strip /* C style */ comments
#635 and #18, require cpphs-1.18.1
Switch to CmdArgs for command line parsing
Remove -x as a synonym for --cross
1.8.57
#6, add a preview of an API
#331, improve parse error locations for literate Haskell
1.8.56
Remove support for GHC 6.12 and below
#317, tone down the void hint
#16, match not . not (and reverse . reverse etc)
Suggest <$> instead of fmap f $ ...
Tweak some priorities, make >=> a warn and void an error
#3, make top of the file ANN pragmas work
#10, add a suggestion to use unlines
#11, add a few hints about characters
#8, add CHANGES.txt to the Cabal package
1.8.55
#627, fix the UnboxedTuples extension warning
1.8.54
Fix a bug when suggesting const
1.8.53
Fix some corner cases when suggesting foldr etc.
#517, don't introduce new free variables in a replacement
1.8.52
#2, Generic is not newtype derivable
1.8.51
Upgrade to haskell-src-exts-1.14
1.8.50
Eliminate upper bounds on all dependencies
#617, fix up notIn to take account of Template Haskell variables
#573, suggest removing various deriving language extensions
1.8.49
Remove ^^ ==> ** hint
Remove a duplicate sqrt hint
Ensure that --test failures throws an error
Fix up the copyright year in --help
1.8.48
Brackets at the root of annotations are fine
Reduce a few more lambda expressions
1.8.47
#613, compatibility with base-4.7
1.8.46
Remove incorrect isPrefixOf hints
#586, add span/break/takeWhile/dropWhile hints
#588, add sort/reverse hints
#601, add replicate/map/repeat hints
Add a hint about reverse/reverse
Add side as an alias for _
Add hint as an alias for error
1.8.45
#600, hints for unnecessary lazy annotations
1.8.44
#598, warn on unnecessary bang patterns
1.8.43
Change some hint error/warning levels
1.8.42
Allow cpphs-1.16
1.8.41
#586, add a rule for takeWhile/dropWhile ==> span
#522, add hints for the state monad
#499, fix up the test suite
Fix the side conditions for the `isPrefixOf` hint
Add hints about take/drop on non positive numbers
Add isNat/isPos/isNeg/isNegPos as notes
Make the notes a structured type
Add --proof feature
Retire the Prelude.catch hint
Additional boolean equality hints
1.8.40
#585, lots of additional list based hints
1.8.39
#582, don't suggest renaming with trailingHashes#
1.8.38
#578, treat _ bindings differently in lambdas
1.8.37
#575, allow cpphs-1.15
1.8.36
Make --with imply no default Hint files
1.8.35
#567, avoid duplicate hints around (.) hints
1.8.34
Switch license from GPL to BSD3
1.8.33
Lots more hints on laziness, foldable and a few others
Use mapM_ etc in more situations, when using explicit >>=
1.8.32
Add notes about how to deal with imported fixites
Add a --with flag for passing settings on the command line
#563, make sure TypeSig hints get the right function name
Update the copyright year to 2012
#564, allow brackets and type signatures on annotations
Add a note that about using !! if the index is negative
1.8.31
Avoid incomplete patterns when reading ANN pragmas
#555, top-level expressions require TemplateHaskell
1.8.30
Add elemIndex/elemIndices hints
Allow cpphs-1.14
#551, allow case_ as a name with an underscore
1.8.29
Allow hscolor-1.20.*
#574, add a hint to for mapM/zip ==> zipWithM
1.8.28
Fix a bug, >=> hint was missing check about removal of free var
1.8.27
Allow haskell-src-exts-1.13.*
1.8.26
Allow haskell-src-exts-1.12.*
Don't suggest redundant brackets when turning ++ into :
Add hints suggesting >=> and <=<
1.8.25
Update the copyright year in the Cabal file
Allow transformers-0.3.*
1.8.24
#531, Make hlint.ghci well formed again
1.8.23
Add hints for redundant seq/evaluate using isWHNF
#526, don't hint for return $! (x :: Int)
1.8.22
Add hint for $! where the RHS is not a variable
1.8.21
#508, add lots of hints from the base library
#317, add hints for a >> return () to void
Add a fromMaybe/fmap ==> maybe hint
#304, don't backet tuple sections
Add foldl (++) [] ==> concat
#512, detect unnecessary case construct
When finding hints, don't abort on a parse error
#507, add exitSuccess hint
#505, suggest record patterns
1.8.20
#500, make sure eta reduction has position information
1.8.19
#498, eta reduce even if there is a where block
#497, don't produce an incorrect lambda when suggesting flip
1.8.18
#438, use Foo.Bar to mean Foo/Bar.hs
Add a --path command line option to say where files live
#441, avoid bad matches due to automatically eta reducing rules
#489, import Foo as Foo is redundant
#481, suggest liftM instead of fmap when using the Monad laws
1.8.17
#479, allow - as the file to specify using stdin
1.8.16
#478, allow cpphs-1.13.1
Never suggest view patterns (they aren't sufficiently better)
Don't suggest use of Data.Ord.comparing, using `on` is better
Only suggest elem/notElem on 3 or more items
1.8.15
Add --cpp-ansi to turn on ANSI compat in cpphs
1.8.14
#455, GHC 7.2 compatibility
Add lots of hints from Lennart Augustsson
1.8.13
#302, add a backup fixity analysis, if the HSE one fails
Fix x /= y || x /= z ==> x `notElem` [y,z], should be &&
1.8.12
Allow cpphs-1.12
1.8.11
#440, suggest removing redundant brackets under do
#439, don't add redundant brackets under do
1.8.10
Upgrade to hscolour-1.19
1.8.9
#436, add a hint about mapMaybe/map
Upgrade to haskell-src-exts-1.11.1
Add a --cross flag, to detect hints between multiple modules
#428, don't suggest using String in an instance head
1.8.8
#384, suggest collapsing multiple imports/exports
#374, don't suggest the removal of necessary brackets
#337, suggest Control.Exception.catch instead of Prelude.catch
#412, add hints based on Control.Exception
#378, suggest removing fromInteger/fromIntegral on literals
#369, add notes to a few hints about possible pitfalls
#409, fix a few cases where definitions suggested themselves
#410, Support test* as ignored items in settings files
#414, add isLit* pattern, and hint about ^^ ==> **
#420, make the suggestion to use let a warning
#408, rework the when/unless hints, don't suggest on itself
Add duplicate detector, for copy/pasted code
#285, don't show duplicate filepath separators
If the user enters directories containing no files then say
Make suggesting curry/uncurry a warning instead of an error
1.8.7
Relax the transformers dependency, works with 0.0.* and 0.1.*
1.8.6
Export suggestionSeverity/Severity from the API
Allow hint imports with "hlint", as well as the existing "hint"
1.8.5
Update the copyright year to 2011
#400, support more encoding strings, give useful errors
#401, rename the report template to report_template.html
Replace filter f x /= [] with any f x, and 2 more similar
1.8.4
#308, allow haskell-src-exts-1.10.1, which parses Unicode better
import qualified Char ==> import qualified Data.Char as Char
#393, fix suggestion for import IO, requires more than System.IO
#376, note that RecordWildCards implies DisambiguateRecordFields
1.8.3
Allow uniplate-1.6
Switch from mtl to transformers
#373, require haskell-src-exts-1.9.6
Add a type signature for GHC 7
Suggest [x | x <- xs] ==> xs, if x is a variable
1.8.2
#371, foo (\x -> y :: Int -> Int) is not a redundant bracket
Add a hint to use just equality rather than isJust/fromJust
1.8.1
Massive speed up for files with many naming hints
#361, keep module names when suggesting infix
Add support for wildcard matching on module names
#357, don't camel case suggest on FOO_A
#370, fix building with GHC 6.10.4
#313, upgrade to haskell-src-exts-1.9.4
Workaround for #358, disable empty where hints
#355, make "--ignore=Parse error" work
Add --cpp-simple to run a simple CPP to strip lines begining #
Add bracketing information if the parent is a case
Suggest intercalate
1.8
Make --test --hint=file typecheck a file for valid hints
#347, Suggest use of otherwise, instead of True, in pattern guards
Add hints about redundant where statements
Suggest removal of redundant guards
Make hints about guards work on patterns/infix matches/case alts
Make finding guards look a child functions
Correctly collapse functions and lambdas using the same patterns
Suggest promoting patterns bound to lambdas to functions
Allow collapsing lambdas sharing pattern variables correctly
#344, only give one warning for multiple collapsable lambdas
#300, substantially improve module name resolution with imports
BREAKING: imports in hint files require import "hint" HintFile
#335, redundant id should only generate one warning
Add a hint for using map (f &&& g)
#328, for foo'bar suggest the naming fooBar
#323, detect redundant brackets in field declarations
#321, force the whole file before displaying a parse error
Make --find more robust, fixes a potential parse error
1.7.3
Upgrade to hscolour-1.17
1.7.2
#318, match rules by expanding out (.)
#319, don't remove lambdas on the right of infix operators
1.7.1
Add a --quiet flag, to supress stdout (mainly for API users)
1.7
Add support for HLint.Builtin.All
Fix crash on (\x -> x)
Make the library correctly honour the data directory
Improve the manual, mainly language changes and hyperlinking
Fix a bug in ListRec, could have _recursive_ in the result
#315, spot list rec hints through $ and let
Add hints based on (f $) ==> f, and change in ListRec hints
Changes to the lambda suggestions, now gives a few more hints
Don't suggest importing modules in old-locale/old-time
Make the API return the suggestions, rather than just the count
#278, add -XNoCpp to disable the C preprocessor
#279, add -XExt/-XNoExt to choose extensions
Remove some redundant brackets in type replacements
#286, remove redundant brackets in match
Additional bracket removal, application under sections
#299, rework hints to use flip (suggest infix in some cases)
Add some fromMaybe hints
Fix bug where hints didn't always get names
#306, make --find use the hints if there are files specified
Upgrade to haskell-src-exts-1.9
#303, allow fixities to be specified in hint files
1.6.21
#287, warn about Haskell 98 imports
#297, add a hint to use mplus
#288, detect redundant brackets under a lambda
#302, remove error about ambiguous fixities
#281, enhance the redundant monad return warnings
#293, eliminate _noParen_ from the result
#284, eliminate ViewPatterns from FindHints, hits compiler bug
#283, don't suggest removal of RecordWildCards
Add some hints about concat and (++)
#273, require haskell-src-exts >= 1.8.2
1.6.20
#275, add more acknowledgements (still very incomplete)
#254, remove the foldr1/map hint
Compress nested lambdas, \x -> \y -> ... ==> \x y -> ...
Fix minor bug on \x -> \x -> foo x x
#274, add redundant bracket inside record update/construct
#272, don't mess up creating sections from qualified names
Add some hints to suggest elem
Add Paths_hlint to the .cabal file, or the library doesn't link
#271, rewrite the match engine in terms of SYB
1.6.19
#251, add automatic definition hunting with --find
#268, rewrite the (.) expansion in hints to fix various bugs
#269, replacing a case with an if should generate one hint
Document the ANN pragmas
Require haskell-src-exts-1.8.1
1.6.18
Remove a hint replacing do x <- foo; bar x with foo >>= bar
#263, support CPP files more fully
Upgrade to hscolour-1.16
Upgrade to cpphs-1.11
1.6.17
Force cpphs-1.10, since 1.11 breaks the interface
More hints from the Data.Maybe module
#262, add support for the TupleSections extension
#264, upgrade to haskell-src-exts-1.8.*, fixes QuasiQuote pos
Upgrade to cpphs 1.10
#266, don't match hints that appear to be the definitions
#248, tone down the eta reduction hints
Add support for WARNING pragma's to reclassify hints
Support ignoring hints on types
Give better error messages on incorrect settings files
Add temporary haskell-src-exts 1.5/1.6 compatibility
#327, add hints to use expressions infix
#240, if a then True else False no longer suggests a || False
Upgrade to haskell-src-exts-1.7.*
#236, support changing the text encoding with --encoding/--utf8
#260, generate nicer lambdas for (($) . f)
Add the hint (($) . f) ==> (f $)
1.6.16
Further performance enhancements (for details see my blog)
Update to uniplate 1.5.* (fixes performance bug)
Improve speed based on profiling (roughly twice as fast)
#245, add hints for excess brackets in types and patterns
Make 100% redundant brackets an error
Fix bug where qualified names did not match
Remove dependency on SYB
#234, allow TH top-level splices for ignore
#110, add tests for ignoring commands
1.6.15
Upgrade to uniplate 1.4.* (fixes performance bug)
#192, make HLint into a fairly basic library
Add --datadir to allow running with a different data directory
#254, eliminate foldl/map fusion rules (which were untrue)
Fix a few typos in the hint rules
Upgrade to uniplate 1.3.*
Upgrade to haskell-src-exts 1.6.*
Add a .ghci file snippet
#247, Fix bug matching expressions containing position info
1.6.14
Upgrade to haskell-src-exts 1.5.*
1.6.13
#246, redundant brackets in [(...)]
Add fold/map fusion hints
Don't suggest namings that are already used in the module
#239, Add suggestions of and/or on foldl
Add --extension flag, to find files not named .hs/.lhs
Only activate the builtin hints when they are imported
Fix matching bug, said "Use flip" on "\v -> f v . g"
Suggest changing some pattern guards to view patterns
1.6.12
Fix a bug with ignored hints being written to reports
Upgrade to haskell-src-exts 1.3.*
#228, suggest let instead of <- return in do statements
#229, suggest comparing
Qualify all non-Prelude function suggestions
#225, Add redundant flip hint
#226, Add ((+) x) ==> (x +)
#223, TemplateHaskell may allow other extensions via code
Fix incorrect suggestion on do x <- f ; g x x
A few small additional hints (use flip, redundant id)
1.6.11
Don't perform type eta reduction
1.6.10
Fix bug, eta reduction on chained infix operators, i.e. x#y#z
1.6.9
#217, don't suggest eta reduction on - or +
Fix bug, PatternGuards under case alternatives were ignored
1.6.8
#213, upgrade to cpphs 1.9
Add suggestion to replace lambda with operator sections
Fix bug, ''Name decided TemplateHaskell was unnecessary
HPC statistics, and increase in test coverage
Fix bug, import A as Y; import A gave import A, missing the as Y
Fix bug, type Foo a = Bar a a incorrectly suggested eta reduce
1.6.7
NOTE: #213 has not been fixed, cpphs can cause hangs
Add threaded flag to Cabal to disable -threaded mode
#212, fix crash
Fix bug, incorrectly decided TemplateHaskell was unnecessary
1.6.6
Upgrade to hscolour 1.15
Add a hint for using unless
#211, add hints for unused extensions
#188, add pragma hints
Add a few additional hints (Functor laws)
#137, add cpphs support
#189, give hints for redundant imports
Upgrade to haskell-src-exts 1.1.*
1.6.5
#206, better presentation of parse errors
#208, give the correct precedence to ==> in source files
1.6.4
Start of changelog
hlint-2.0.11/src/ 0000755 0000000 0000000 00000000000 13210071537 011665 5 ustar 00 0000000 0000000 hlint-2.0.11/src/Util.hs 0000644 0000000 0000000 00000004161 13210071537 013140 0 ustar 00 0000000 0000000 {-# LANGUAGE ExistentialQuantification, Rank2Types #-}
module Util(
defaultExtensions,
gzip, universeParentBi,
exitMessage, exitMessageImpure
) where
import Data.List
import System.Exit
import System.IO
import System.IO.Unsafe
import Unsafe.Coerce
import Data.Data
import Data.Generics.Uniplate.Operations
import Language.Haskell.Exts.Extension
---------------------------------------------------------------------
-- SYSTEM.IO
exitMessage :: String -> IO a
exitMessage msg = do
hPutStrLn stderr msg
exitWith $ ExitFailure 1
exitMessageImpure :: String -> a
exitMessageImpure = unsafePerformIO . exitMessage
---------------------------------------------------------------------
-- DATA.GENERICS
data Box = forall a . Data a => Box a
gzip :: Data a => (forall b . Data b => b -> b -> c) -> a -> a -> Maybe [c]
gzip f x y | toConstr x /= toConstr y = Nothing
| otherwise = Just $ zipWith op (gmapQ Box x) (gmapQ Box y)
-- unsafeCoerce is safe because gmapQ on the same constr gives the same fields
-- in the same order
where op (Box x) (Box y) = f x (unsafeCoerce y)
---------------------------------------------------------------------
-- DATA.GENERICS.UNIPLATE.OPERATIONS
universeParent :: Uniplate a => a -> [(Maybe a, a)]
universeParent x = (Nothing,x) : f x
where
f :: Uniplate a => a -> [(Maybe a, a)]
f x = concat [(Just x, y) : f y | y <- children x]
universeParentBi :: Biplate a b => a -> [(Maybe b, b)]
universeParentBi = concatMap universeParent . childrenBi
---------------------------------------------------------------------
-- LANGUAGE.HASKELL.EXTS.EXTENSION
defaultExtensions :: [Extension]
defaultExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions
badExtensions =
[Arrows -- steals proc
,TransformListComp -- steals the group keyword
,XmlSyntax, RegularPatterns -- steals a-b
,UnboxedTuples -- breaks (#) lens operator
,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break
,DoRec, RecursiveDo -- breaks rec
,TypeApplications -- HSE fails on @ patterns
]
hlint-2.0.11/src/Report.hs 0000644 0000000 0000000 00000005266 13210071537 013505 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards #-}
module Report(writeReport) where
import Idea
import Data.Tuple.Extra
import Data.List.Extra
import Data.Maybe
import Data.Version
import System.FilePath
import System.IO.Extra
import HSE.All
import Paths_hlint
import HsColour
writeTemplate :: FilePath -> [(String,[String])] -> FilePath -> IO ()
writeTemplate dataDir content to = do
src <- readFile' $ dataDir "report_template.html"
writeFile to $ unlines $ concatMap f $ lines src
where
f ('$':xs) = fromMaybe ['$':xs] $ lookup xs content
f x = [x]
writeReport :: FilePath -> FilePath -> [Idea] -> IO ()
writeReport dataDir file ideas = writeTemplate dataDir inner file
where
generateIds :: [String] -> [(String,Int)] -- sorted by name
generateIds = map (head &&& length) . group -- must be already sorted
files = generateIds $ sort $ map (srcSpanFilename . ideaSpan) ideas
hints = generateIds $ map hintName $ sortOn (negate . fromEnum . ideaSeverity &&& hintName) ideas
hintName x = show (ideaSeverity x) ++ ": " ++ ideaHint x
inner = [("VERSION",['v' : showVersion version]),("CONTENT",content),
("HINTS",list "hint" hints),("FILES",list "file" files)]
content = concatMap (\i -> writeIdea (getClass i) i) ideas
getClass i = "hint" ++ f hints (hintName i) ++ " file" ++ f files (srcSpanFilename $ ideaSpan i)
where f xs x = show $ fromJust $ findIndex ((==) x . fst) xs
list mode = zipWith f [0..]
where
f i (name,n) = "
"
where id = mode ++ show i
writeIdea :: String -> Idea -> [String]
writeIdea cls Idea{..} =
["
"
,escapeHTML (showSrcLoc (getPointLoc ideaSpan) ++ ": " ++ show ideaSeverity ++ ": " ++ ideaHint) ++ " "
,"Found "
,hsColourHTML ideaFrom] ++
(case ideaTo of
Nothing -> []
Just to ->
["Why not" ++ (if to == "" then " remove it." else "") ++ " "
,hsColourHTML to]) ++
[let n = showNotes ideaNote in if n /= "" then "Note: " ++ writeNote n ++ "" else ""
,"
"
,""]
-- Unescaped, but may have `backticks` for code
writeNote :: String -> String
writeNote = f . splitOn "`"
where f (a:b:c) = escapeHTML a ++ "" ++ escapeHTML b ++ "" ++ f c
f xs = concatMap escapeHTML xs
escapeHTML :: String -> String
escapeHTML = concatMap f
where
f '>' = ">"
f '<' = "<"
f '&' = "&"
f x = [x]
hlint-2.0.11/src/Refact.hs 0000644 0000000 0000000 00000000657 13210071537 013435 0 ustar 00 0000000 0000000 module Refact(toRefactSrcSpan, toSS) where
import qualified Refact.Types as R
import HSE.All
toRefactSrcSpan :: SrcSpan -> R.SrcSpan
toRefactSrcSpan ss = R.SrcSpan (srcSpanStartLine ss)
(srcSpanStartColumn ss)
(srcSpanEndLine ss)
(srcSpanEndColumn ss)
toSS :: Annotated a => a S -> R.SrcSpan
toSS = toRefactSrcSpan . srcInfoSpan . ann
hlint-2.0.11/src/Parallel.hs 0000644 0000000 0000000 00000002314 13210071537 013755 0 ustar 00 0000000 0000000 {-
The parallel function (specialised to lists) is equivalent to:
import Control.Parallel.Strategies
parallel :: [IO [a]] -> IO [[a]]
parallel = return . withStrategy (parList $ seqList r0) . map unsafePerformIO
However, this version performs about 10% slower with 2 processors in GHC 6.12.1
-}
module Parallel(parallel) where
import System.IO.Unsafe
import Control.Concurrent
import Control.Exception
import Control.Monad
parallel :: Int -> [IO a] -> IO [a]
parallel j = if j <= 1 then parallel1 else parallelN j
parallel1 :: [IO a] -> IO [a]
parallel1 [] = return []
parallel1 (x:xs) = do
x2 <- x
xs2 <- unsafeInterleaveIO $ parallel1 xs
return $ x2:xs2
parallelN :: Int -> [IO a] -> IO [a]
parallelN j xs = do
ms <- mapM (const newEmptyMVar) xs
chan <- newChan
mapM_ (writeChan chan . Just) $ zip ms xs
replicateM_ j (writeChan chan Nothing >> forkIO (f chan))
let throwE x = throw (x :: SomeException)
parallel1 $ map (fmap (either throwE id) . takeMVar) ms
where
f chan = do
v <- readChan chan
case v of
Nothing -> return ()
Just (m,x) -> do
putMVar m =<< try x
f chan
hlint-2.0.11/src/Main.hs 0000644 0000000 0000000 00000000372 13210071537 013107 0 ustar 00 0000000 0000000
module Main(main) where
import Language.Haskell.HLint3
import Control.Monad
import System.Environment
import System.Exit
main :: IO ()
main = do
args <- getArgs
errs <- hlint args
unless (null errs) $
exitWith $ ExitFailure 1
hlint-2.0.11/src/Idea.hs 0000644 0000000 0000000 00000007227 13210071537 013073 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards, NoMonomorphismRestriction #-}
module Idea(
Idea(..),
rawIdea, idea, suggest, warn, ignore,
rawIdeaN, suggestN,
showIdeasJson, showANSI,
Note(..), showNotes,
Severity(..)
) where
import Data.List.Extra
import Data.Char
import Numeric
import HSE.All
import Config.Type
import HsColour
import Refact.Types hiding (SrcSpan)
import qualified Refact.Types as R
-- | An idea suggest by a 'Hint'.
data Idea = Idea
{ideaModule :: String -- ^ The module the idea applies to, may be @\"\"@ if the module cannot be determined or is a result of cross-module hints.
,ideaDecl :: String -- ^ The declaration the idea applies to, typically the function name, but may be a type name.
,ideaSeverity :: Severity -- ^ The severity of the idea, e.g. 'Warning'.
,ideaHint :: String -- ^ The name of the hint that generated the idea, e.g. @\"Use reverse\"@.
,ideaSpan :: SrcSpan -- ^ The source code the idea relates to.
,ideaFrom :: String -- ^ The contents of the source code the idea relates to.
,ideaTo :: Maybe String -- ^ The suggested replacement, or 'Nothing' for no replacement (e.g. on parse errors).
,ideaNote :: [Note] -- ^ Notes about the effect of applying the replacement.
,ideaRefactoring :: [Refactoring R.SrcSpan] -- ^ How to perform this idea
}
deriving (Eq,Ord)
-- I don't use aeson here for 2 reasons:
-- 1) Aeson doesn't esape unicode characters, and I want to (allows me to ignore encoding)
-- 2) I want to control the format so it's slightly human readable as well
showIdeaJson :: Idea -> String
showIdeaJson idea@Idea{ideaSpan=srcSpan@SrcSpan{..}, ..} = wrap . intercalate "," . map mkPair $
[("module", str ideaModule)
,("decl", str ideaDecl)
,("severity", str $ show ideaSeverity)
,("hint", str ideaHint)
,("file", str srcSpanFilename)
,("startLine", show srcSpanStartLine)
,("startColumn", show srcSpanStartColumn)
,("endLine", show srcSpanEndLine)
,("endColumn", show srcSpanEndColumn)
,("from", str ideaFrom)
,("to", maybe "null" str ideaTo)
,("note", "[" ++ intercalate "," (map (str . show) ideaNote) ++ "]")
,("refactorings", str $ show ideaRefactoring)
]
where
str x = "\"" ++ concatMap f x ++ "\""
where f '\"' = "\\\""
f '\\' = "\\\\"
f '\n' = "\\n"
f '\r' = "\\r"
f x | isControl x || not (isAscii x) = "\\u" ++ takeEnd 4 ("0000" ++ showHex (ord x) "")
f x = [x]
mkPair (k, v) = show k ++ ":" ++ v
wrap x = "{" ++ x ++ "}"
showIdeasJson :: [Idea] -> String
showIdeasJson ideas = "[" ++ intercalate "\n," (map showIdeaJson ideas) ++ "]"
instance Show Idea where
show = showEx id
showANSI :: IO (Idea -> String)
showANSI = do
f <- hsColourConsole
return $ showEx f
showEx :: (String -> String) -> Idea -> String
showEx tt Idea{..} = unlines $
[showSrcLoc (getPointLoc ideaSpan) ++ ": " ++ (if ideaHint == "" then "" else show ideaSeverity ++ ": " ++ ideaHint)] ++
f "Found" (Just ideaFrom) ++ f "Why not" ideaTo ++
["Note: " ++ n | let n = showNotes ideaNote, n /= ""]
where
f msg Nothing = []
f msg (Just x) | null xs = [msg ++ " remove it."]
| otherwise = (msg ++ ":") : map (" "++) xs
where xs = lines $ tt x
rawIdea = Idea "" ""
rawIdeaN a b c d e f = Idea "" "" a b c d e f []
idea severity hint from to = rawIdea severity hint (srcInfoSpan $ ann from) (f from) (Just $ f to) []
where f = trimStart . prettyPrint
suggest = idea Suggestion
warn = idea Warning
ignore = idea Ignore
ideaN severity hint from to = idea severity hint from to []
suggestN = ideaN Suggestion
hlint-2.0.11/src/HsColour.hs 0000644 0000000 0000000 00000001060 13210071537 013754 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
module HsColour(hsColourHTML, hsColourConsole) where
#ifdef GPL_SCARES_ME
hsColourConsole :: IO (String -> String)
hsColourConsole = return id
hsColourHTML :: String -> String
hsColourHTML = id
#else
import Language.Haskell.HsColour.TTY as TTY
import Language.Haskell.HsColour.Colourise
import Language.Haskell.HsColour.CSS as CSS
hsColourConsole :: IO (String -> String)
hsColourConsole = do
prefs <- readColourPrefs
return $ TTY.hscolour prefs
hsColourHTML :: String -> String
hsColourHTML = CSS.hscolour False 1
#endif
hlint-2.0.11/src/HLint.hs 0000644 0000000 0000000 00000022162 13210071537 013242 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards, TupleSections #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module HLint(hlint, readAllSettings) where
import Control.Applicative
import Control.Monad.Extra
import Control.Exception
import Control.Concurrent.Extra
import System.Console.CmdArgs.Verbosity
import Data.List.Extra
import GHC.Conc
import System.Exit
import System.IO.Extra
import Data.Tuple.Extra
import Prelude
import Data.Version.Extra
import System.Process.Extra
import Data.Maybe
import System.Directory
import System.FilePath
import CmdLine
import Config.Read
import Config.Type
import Config.Compute
import Report
import Idea
import Apply
import Test.All
import Hint.All
import Grep
import Test.Proof
import Parallel
import HSE.All
import CC
-- | This function takes a list of command line arguments, and returns the given hints.
-- To see a list of arguments type @hlint --help@ at the console.
-- This function writes to the stdout/stderr streams, unless @--quiet@ is specified.
--
-- As an example:
--
-- > do hints <- hlint ["src", "--ignore=Use map","--quiet"]
-- > when (length hints > 3) $ error "Too many hints!"
--
-- /Warning:/ The flags provided by HLint are relatively stable, but do not have the same
-- API stability guarantees as the rest of the strongly-typed API. Do not run this function
-- on a your server with untrusted input.
hlint :: [String] -> IO [Idea]
hlint args = do
cmd <- getCmd args
case cmd of
CmdMain{} -> do xs <- hlintMain args cmd; return $ if cmdNoExitCode cmd then [] else xs
CmdGrep{} -> hlintGrep cmd >> return []
CmdHSE{} -> hlintHSE cmd >> return []
CmdTest{} -> hlintTest cmd >> return []
hlintHSE :: Cmd -> IO ()
hlintHSE c@CmdHSE{..} = do
v <- getVerbosity
forM_ cmdFiles $ \x -> do
putStrLn $ "Parse result of " ++ x ++ ":"
let (lang,exts) = cmdExtensions c
-- We deliberately don't use HSE.All here to avoid any bugs in HLint
-- polluting our bug reports (which is the main use of HSE)
res <- parseFileWithMode defaultParseMode{baseLanguage=lang, extensions=exts} x
case res of
x@ParseFailed{} -> print x
ParseOk m -> case v of
Loud -> print m
Quiet -> print $ prettyPrint m
_ -> print $ void m
putStrLn ""
hlintTest :: Cmd -> IO ()
hlintTest cmd@CmdTest{..} =
if not $ null cmdProof then do
files <- cmdHintFiles cmd
s <- readFilesConfig $ map (,Nothing) 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
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
error "No files found"
else
runGrep cmdPattern (cmdParseFlags cmd) files
withVerbosity :: Verbosity -> IO a -> IO a
withVerbosity new act = do
old <- getVerbosity
(setVerbosity new >> act) `finally` setVerbosity old
hlintMain :: [String] -> Cmd -> IO [Idea]
hlintMain args cmd@CmdMain{..}
| cmdDefault = do
ideas <- if null cmdFiles then return [] else withVerbosity Quiet $
runHlintMain args cmd{cmdJson=False,cmdSerialise=False,cmdRefactor=False} Nothing
let bad = nubOrd $ map ideaHint ideas
src <- readFile $ cmdDataDir "default.yaml"
if null bad then putStr src else do
let group1:groups = splitOn ["",""] $ lines src
let group2 = "# Warnings currently triggered by your code" :
["- ignore: {name: " ++ show x ++ "}" | x <- bad]
putStr $ unlines $ intercalate ["",""] $ group1:group2:groups
return []
| null cmdFiles && not (null cmdFindHints) = do
hints <- concatMapM (resolveFile cmd Nothing) cmdFindHints
mapM_ (putStrLn . fst <=< computeSettings (cmdParseFlags cmd)) hints >> return []
| null cmdFiles =
exitWithHelp
| cmdRefactor =
withTempFile $ runHlintMain args cmd . Just
| otherwise =
runHlintMain args cmd Nothing
runHlintMain :: [String] -> Cmd -> Maybe FilePath -> IO [Idea]
runHlintMain args cmd tmpFile = do
(cmd, settings) <- readAllSettings args cmd
runHints args settings =<< resolveFiles cmd tmpFile
resolveFiles :: Cmd -> Maybe FilePath -> IO Cmd
resolveFiles cmd@CmdMain{..} tmpFile = do
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
files <- cmdHintFiles cmd
settings1 <- readFilesConfig $ map (,Nothing) files ++ [("CommandLine.hs",Just x) | x <- cmdWithHints]
let args2 = [x | SettingArgument x <- settings1]
cmd@CmdMain{..} <- if null args2 then return cmd else getCmd $ args1 ++ args2
settings2 <- concatMapM (fmap snd . computeSettings (cmdParseFlags cmd)) cmdFindHints
settings3 <- return [SettingClassify $ Classify Ignore x "" "" | x <- cmdIgnore]
return (cmd, settings1 ++ settings2 ++ settings3)
runHints :: [String] -> [Setting] -> Cmd -> IO [Idea]
runHints args settings cmd@CmdMain{..} = do
j <- if cmdThreads == 0 then getNumProcessors else return cmdThreads
withNumCapabilities j $ do
let outStrLn = whenNormal . putStrLn
ideas <- getIdeas cmd settings
ideas <- return $ if cmdShowAll then ideas else filter (\i -> ideaSeverity i /= Ignore) ideas
if cmdJson then
putStrLn $ showIdeasJson ideas
else if cmdCC then
mapM_ (printIssue . fromIdea) ideas
else if cmdSerialise then do
hSetBuffering stdout NoBuffering
print $ map (show &&& ideaRefactoring) ideas
else if cmdRefactor then
handleRefactoring ideas cmdFiles cmd
else do
usecolour <- cmdUseColour cmd
showItem <- if usecolour then showANSI else return show
mapM_ (outStrLn . showItem) ideas
handleReporting ideas cmd
return ideas
getIdeas :: Cmd -> [Setting] -> IO [Idea]
getIdeas cmd@CmdMain{..} settings = do
settings <- return $ settings ++ map (Builtin . fst) builtinHints
let flags = cmdParseFlags cmd
ideas <- if cmdCross
then applyHintFiles flags settings cmdFiles
else concat <$> parallel cmdThreads [evaluateList =<< applyHintFile flags settings x Nothing | x <- cmdFiles]
return $ if not (null cmdOnly)
then [i | i <- ideas, ideaHint i `elem` cmdOnly]
else ideas
handleRefactoring :: [Idea] -> [String] -> Cmd -> IO ()
handleRefactoring ideas files cmd@CmdMain{..} =
case cmdFiles of
[file] -> do
-- Ensure that we can find the executable
path <- checkRefactor (if cmdWithRefactor == "" then Nothing else Just cmdWithRefactor)
-- writeFile "hlint.refact"
let hints = show $ map (show &&& ideaRefactoring) ideas
withTempFile $ \f -> do
writeFile f hints
exitWith =<< runRefactoring path file f cmdRefactorOptions
_ -> error "Refactor flag can only be used with an individual file"
handleReporting :: [Idea] -> Cmd -> IO ()
handleReporting showideas cmd@CmdMain{..} = do
let outStrLn = whenNormal . putStrLn
if null showideas then
when (cmdReports /= []) $ outStrLn "Skipping writing reports"
else
forM_ cmdReports $ \x -> do
outStrLn $ "Writing report to " ++ x ++ " ..."
writeReport cmdDataDir x showideas
unless cmdNoSummary $ do
let n = length showideas
outStrLn $ if n == 0 then "No hints" else show n ++ " hint" ++ ['s' | n/=1]
runRefactoring :: FilePath -> FilePath -> FilePath -> String -> IO ExitCode
runRefactoring rpath fin hints opts = do
let args = [fin, "-v0"] ++ words opts ++ ["--refact-file", hints]
(_, _, _, 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
checkRefactor :: Maybe FilePath -> IO FilePath
checkRefactor rpath = do
let excPath = fromMaybe "refactor" rpath
mexc <- findExecutable excPath
case mexc of
Just exc -> do
ver <- readVersion . tail <$> readProcess exc ["--version"] ""
if versionBranch ver >= [0,1,0,0]
then return exc
else error "Your version of refactor is too old, please upgrade to the latest version"
Nothing -> error $ unlines [ "Could not find refactor", "Tried with: " ++ excPath ]
evaluateList :: [a] -> IO [a]
evaluateList xs = do
evaluate $ length xs
return xs
hlint-2.0.11/src/Grep.hs 0000644 0000000 0000000 00000002163 13210071537 013120 0 ustar 00 0000000 0000000
module Grep(runGrep) where
import Hint.All
import Apply
import Config.Type
import HSE.All
import Control.Monad
import Data.List
import Util
import Idea
runGrep :: String -> ParseFlags -> [FilePath] -> IO ()
runGrep patt flags files = do
exp <- case parseExp patt of
ParseOk x -> return x
ParseFailed sl msg ->
exitMessage $ (if "Parse error" `isPrefixOf` msg then msg else "Parse error in pattern: " ++ msg) ++ "\n" ++
patt ++ "\n" ++
replicate (srcColumn sl - 1) ' ' ++ "^"
let scope = scopeCreate $ Module an Nothing [] [] []
let rule = hintRules [HintRule Suggestion "grep" scope exp (Tuple an Boxed []) 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) (mkSrcSpan sl sl) ctxt Nothing []
Right m ->
forM_ (applyHints [] rule [m]) $ \i ->
print i{ideaHint="", ideaTo=Nothing}
hlint-2.0.11/src/CmdLine.hs 0000644 0000000 0000000 00000034303 13210071537 013537 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-missing-fields -fno-cse -O0 #-}
module CmdLine(
Cmd(..), getCmd,
CppFlags(..), cmdCpp, cmdExtensions, cmdHintFiles, cmdUseColour,
exitWithHelp, resolveFile
) where
import Control.Monad.Extra
import Data.Char
import Data.List
import System.Console.ANSI(hSupportsANSI)
import System.Console.CmdArgs.Implicit
import System.Console.CmdArgs.Explicit(helpText, HelpFormat(..))
import System.Directory.Extra
import System.Exit
import System.FilePath
import System.IO
import System.Process(readProcess)
import Language.Preprocessor.Cpphs
import HSE.All(CppFlags(..))
import Language.Haskell.Exts(defaultParseMode, baseLanguage)
import Language.Haskell.Exts.Extension
import Data.Maybe
import System.Environment.Extra
import System.Info.Extra
import Util
import Paths_hlint
import Data.Version
getCmd :: [String] -> IO Cmd
getCmd args = withArgs (map f args) $ automatic =<< cmdArgsRun mode
where f x = if x == "-?" || x == "--help" then "--help=all" else x
automatic :: Cmd -> IO Cmd
automatic cmd = case cmd of
CmdMain{} -> dataDir =<< path =<< git =<< extension cmd
CmdGrep{} -> path =<< extension cmd
CmdTest{} -> dataDir cmd
_ -> return cmd
where
path cmd = return $ if null $ cmdPath cmd then cmd{cmdPath=["."]} else cmd
extension cmd = return $ if null $ cmdExtension cmd then cmd{cmdExtension=["hs","lhs"]} else cmd
dataDir cmd
| cmdDataDir cmd /= "" = return cmd
| otherwise = do
x <- getDataDir
b <- doesDirectoryExist x
if b then return cmd{cmdDataDir=x} else do
exe <- getExecutablePath
return cmd{cmdDataDir = takeDirectory exe "data"}
git cmd
| cmdGit cmd = do
mgit <- findExecutable "git"
case mgit of
Nothing -> error "Could not find git"
Just git -> do
let args = ["ls-files", "--cached", "--others", "--exclude-standard"] ++
map ("*." ++) (cmdExtension cmd)
files <- readProcess git args ""
return cmd{cmdFiles = cmdFiles cmd ++ lines files}
| otherwise = return cmd
exitWithHelp :: IO a
exitWithHelp = do
putStr $ show $ helpText [] HelpFormatAll mode
exitSuccess
-- | When to colour terminal output.
data ColorMode
= Never -- ^ Terminal output will never be coloured.
| Always -- ^ Terminal output will always be coloured.
| Auto -- ^ Terminal output will be coloured if $TERM and stdout appear to support it.
deriving (Show, Typeable, Data)
instance Default ColorMode where
def = if isWindows then Never else Auto
data Cmd
= CmdMain
{cmdFiles :: [FilePath] -- ^ which files to run it on, nothing = none given
,cmdReports :: [FilePath] -- ^ where to generate reports
,cmdGivenHints :: [FilePath] -- ^ which settignsfiles were explicitly given
,cmdWithHints :: [String] -- ^ hints that are given on the command line
,cmdGit :: Bool -- ^ use git ls-files to find files
,cmdColor :: ColorMode -- ^ color the result
,cmdThreads :: Int -- ^ Numbmer of threads to use, 0 = whatever GHC has
,cmdIgnore :: [String] -- ^ the hints to ignore
,cmdShowAll :: Bool -- ^ display all skipped items
,cmdExtension :: [String] -- ^ extensions
,cmdLanguage :: [String] -- ^ the extensions (may be prefixed by "No")
,cmdCross :: Bool -- ^ work between source files, applies to hints such as duplicate code between modules
,cmdFindHints :: [FilePath] -- ^ source files to look for hints in
,cmdDataDir :: FilePath -- ^ the data directory
,cmdDefault :: Bool -- ^ Print a default file to stdout
,cmdPath :: [String]
,cmdCppDefine :: [String]
,cmdCppInclude :: [FilePath]
,cmdCppFile :: [FilePath]
,cmdCppSimple :: Bool
,cmdCppAnsi :: Bool
,cmdJson :: Bool -- ^ display hint data as JSON
,cmdCC :: Bool -- ^ display hint data as Code Climate Issues
,cmdNoSummary :: Bool -- ^ do not show the summary info
,cmdOnly :: [String] -- ^ specify which hints explicitly
,cmdNoExitCode :: Bool
,cmdSerialise :: Bool -- ^ Display hints in serialisation format
,cmdRefactor :: Bool -- ^ Run the `refactor` executable to automatically perform hints
,cmdRefactorOptions :: String -- ^ Options to pass to the `refactor` executable.
,cmdWithRefactor :: FilePath -- ^ Path to refactor tool
}
| 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
,cmdWithHints :: [String] -- ^ hints that are given on the command line
,cmdTempDir :: FilePath -- ^ temporary directory to put the files in
,cmdQuickCheck :: Bool
,cmdTypeCheck :: Bool
}
| CmdHSE
{cmdFiles :: [FilePath]
,cmdLanguage :: [String] -- ^ the extensions (may be prefixed by "No")
}
deriving (Data,Typeable,Show)
mode = cmdArgsMode $ modes
[CmdMain
{cmdFiles = def &= args &= typ "FILE/DIR"
,cmdReports = nam "report" &= opt "report.html" &= typFile &= help "Generate a report in HTML"
,cmdGivenHints = nam "hint" &= typFile &= help "Hint/ignore file to use"
,cmdWithHints = nam "with" &= typ "HINT" &= help "Extra hints 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)"
,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"
,cmdExtension = nam "extension" &= typ "EXT" &= help "File extensions to search (default hs/lhs)"
,cmdLanguage = nam_ "language" &= name "X" &= typ "EXTENSION" &= help "Language extensions (Arrows, NoCPP)"
,cmdCross = nam_ "cross" &= help "Work between modules"
,cmdFindHints = nam "find" &= typFile &= help "Find hints in a Haskell file"
,cmdDataDir = nam_ "datadir" &= typDir &= help "Override the data directory"
,cmdDefault = nam "default" &= help "Print a default file to stdout"
,cmdPath = nam "path" &= help "Directory in which to search for files"
,cmdCppDefine = nam_ "cpp-define" &= typ "NAME[=VALUE]" &= help "CPP #define"
,cmdCppInclude = nam_ "cpp-include" &= typDir &= help "CPP include path"
,cmdCppFile = nam_ "cpp-file" &= typFile &= help "CPP pre-include file"
,cmdCppSimple = nam_ "cpp-simple" &= help "Use a simple CPP (strip # lines)"
,cmdCppAnsi = nam_ "cpp-ansi" &= help "Use CPP in ANSI compatibility mode"
,cmdJson = nam_ "json" &= help "Display hint data as JSON"
,cmdCC = nam_ "cc" &= help "Display hint data as Code Climate Issues"
,cmdNoSummary = nam_ "no-summary" &= help "Do not show summary information"
,cmdOnly = nam "only" &= typ "HINT" &= help "Specify which hints explicitly"
,cmdNoExitCode = nam_ "no-exit-code" &= help "Do not give a negative exit if hints"
,cmdSerialise = nam_ "serialise" &= help "Serialise hint data for consumption by apply-refact"
,cmdRefactor = nam_ "refactor" &= help "Automatically invoke `refactor` to apply hints"
,cmdRefactorOptions = nam_ "refactor-options" &= typ "OPTIONS" &= help "Options to pass to the `refactor` executable"
, cmdWithRefactor = nam_ "with-refactor" &= help "Give the path to refactor"
} &= 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)"
} &= 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:"
," hlint src --report"]
,CmdHSE
{} &= explicit &= name "hse"
] &= program "hlint" &= verbosity
&= summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2017")
where
nam xs = nam_ xs &= name [head xs]
nam_ xs = def &= explicit &= name xs
-- | Where should we find the configuration files?
-- * If someone passes cmdWithHints, only look at files they explicitly request
-- * If someone passes an explicit hint name, automatically merge in data/hlint.yaml
-- We want more important hints to go last, since they override
cmdHintFiles :: Cmd -> IO [FilePath]
cmdHintFiles cmd = do
let explicit1 = [cmdDataDir cmd "hlint.yaml" | null $ cmdWithHints cmd]
let explicit2 = cmdGivenHints cmd
bad <- filterM (notM . doesFileExist) $ explicit1 ++ explicit2
when (bad /= []) $
fail $ unlines $ "Failed to find requested hint files:" : map (" "++) bad
if cmdWithHints cmd /= [] then return $ explicit1 ++ explicit2 else do
-- we follow the stylish-haskell config file search policy
-- 1) current directory or its ancestors; 2) home directory
curdir <- getCurrentDirectory
home <- getHomeDirectory
b <- doesFileExist ".hlint.yaml"
implicit <- findM doesFileExist $
"HLint.hs" : -- the default in HLint 1.*
map ( ".hlint.yaml") (ancestors curdir ++ [home]) -- to match Stylish Haskell
return $ explicit1 ++ maybeToList implicit ++ explicit2
where
ancestors = init . map joinPath . reverse . inits . splitPath
cmdExtensions :: Cmd -> (Language, [Extension])
cmdExtensions = getExtensions . cmdLanguage
cmdCpp :: Cmd -> CppFlags
cmdCpp cmd
| cmdCppSimple cmd = CppSimple
| EnableExtension CPP `elem` snd (cmdExtensions cmd) = Cpphs defaultCpphsOptions
{boolopts=defaultBoolOptions{hashline=False, stripC89=True, ansi=cmdCppAnsi cmd}
,includes = cmdCppInclude cmd
,preInclude = cmdCppFile cmd
,defines = [(a,drop 1 b) | x <- cmdCppDefine cmd, let (a,b) = break (== '=') x]
}
| otherwise = NoCpp
-- | Determines whether to use colour or not.
cmdUseColour :: Cmd -> IO Bool
cmdUseColour cmd = case cmdColor cmd of
Always -> return True
Never -> return False
Auto -> hSupportsANSI stdout
"." <\> x = x
x <\> y = x y
resolveFile
:: Cmd
-> Maybe FilePath -- ^ Temporary file
-> FilePath -- ^ File to resolve, may be "-" for stdin
-> IO [FilePath]
resolveFile cmd = getFile (cmdPath cmd) (cmdExtension cmd)
getFile :: [FilePath] -> [String] -> Maybe FilePath -> FilePath -> IO [FilePath]
getFile path _ (Just tmpfile) "-" =
getContents >>= writeFile tmpfile >> return [tmpfile]
getFile path _ Nothing "-" = return ["-"]
getFile [] exts _ file = exitMessage $ "Couldn't find file: " ++ file
getFile (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))
avoidFile x = let y = takeFileName x in "." `isPrefixOf` y
xs <- listFilesInside (return . not . avoidDir) $ p <\> file
return [x | x <- xs, drop 1 (takeExtension x) `elem` exts, not $ avoidFile x]
else do
isFil <- doesFileExist $ p <\> file
if isFil then return [p <\> file]
else do
res <- getModule p exts file
case res of
Just x -> return [x]
Nothing -> getFile ath exts t file
getModule :: FilePath -> [String] -> FilePath -> IO (Maybe FilePath)
getModule path exts x | not (any isSpace x) && all isMod xs = f exts
where
xs = words $ map (\x -> if x == '.' then ' ' else x) x
isMod (x:xs) = isUpper x && all (\x -> isAlphaNum x || x == '_') xs
isMod _ = False
pre = path <\> joinPath xs
f [] = return Nothing
f (x:xs) = do
let s = pre <.> x
b <- doesFileExist s
if b then return $ Just s else f xs
getModule _ _ _ = return Nothing
getExtensions :: [String] -> (Language, [Extension])
getExtensions args = (lang, foldl f (if null langs then defaultExtensions else []) exts)
where
lang = if null langs then baseLanguage defaultParseMode else fromJust $ lookup (last langs) ls
(langs, exts) = partition (isJust . flip lookup ls) args
ls = [(show x, x) | x <- knownLanguages]
f a "Haskell98" = []
f a ('N':'o':x) | Just x <- readExtension x = delete x a
f a x | Just x <- readExtension x = x : delete x a
f a x = exitMessageImpure $ "Unknown extension: " ++ x
readExtension :: String -> Maybe Extension
readExtension x = case classifyExtension x of
UnknownExtension _ -> Nothing
x -> Just x
hlint-2.0.11/src/CC.hs 0000644 0000000 0000000 00000007522 13210071537 012514 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- |
--
-- Utility for formatting @'Idea'@ data in accordance with the Code Climate
-- spec:
--
module CC
( printIssue
, fromIdea
) where
import Data.Aeson (ToJSON(..), (.=), encode, object)
import Data.Char (toUpper)
import Data.Monoid ((<>))
import Data.Text (Text)
import Language.Haskell.Exts.SrcLoc (SrcSpan(..))
import qualified Data.Text as T
import qualified Data.ByteString.Lazy.Char8 as C8
import Idea (Idea(..), Severity(..))
data Issue = Issue
{ issueType :: Text
, issueCheckName :: Text
, issueDescription :: Text
, issueContent :: Text
, issueCategories :: [Text]
, issueLocation :: Location
, issueRemediationPoints :: Int
}
data Location = Location FilePath Position Position
data Position = Position Int Int
instance ToJSON Issue where
toJSON Issue{..} = object
[ "type" .= issueType
, "check_name" .= issueCheckName
, "description" .= issueDescription
, "content" .= object
[ "body" .= issueContent
]
, "categories" .= issueCategories
, "location" .= issueLocation
, "remediation_points" .= issueRemediationPoints
]
instance ToJSON Location where
toJSON (Location path begin end) = object
[ "path" .= path
, "positions" .= object
[ "begin" .= begin
, "end" .= end
]
]
instance ToJSON Position where
toJSON (Position line column) = object
[ "line" .= line
, "column" .= column
]
-- | Print an @'Issue'@ with trailing null-terminator and newline
--
-- The trailing newline will be ignored, but makes the output more readable
--
printIssue :: Issue -> IO ()
printIssue = C8.putStrLn . (<> "\0") . encode
-- | Convert an hlint @'Idea'@ to a datatype more easily serialized for CC
fromIdea :: Idea -> Issue
fromIdea Idea{..} = Issue
{ issueType = "issue"
, issueCheckName = "HLint/" <> T.pack (camelize ideaHint)
, issueDescription = T.pack ideaHint
, issueContent = content ideaFrom ideaTo <> listNotes ideaNote
, issueCategories = categories ideaHint
, issueLocation = fromSrcSpan ideaSpan
, issueRemediationPoints = points ideaSeverity
}
where
content from Nothing = T.unlines
[ "Found"
, ""
, "```"
, T.pack from
, "```"
, ""
, "remove it."
]
content from (Just to) = T.unlines
[ "Found"
, ""
, "```"
, T.pack from
, "```"
, ""
, "Why not"
, ""
, "```"
, T.pack to
, "```"
]
listNotes [] = ""
listNotes notes = T.unlines $
[ ""
, "Applying this change:"
, ""
] ++ map (("* " <>) . T.pack . show) notes
categories _ = ["Style"]
points Ignore = 0
points Suggestion = basePoints
points Warning = 5 * basePoints
points Error = 10 * basePoints
fromSrcSpan :: SrcSpan -> Location
fromSrcSpan SrcSpan{..} = Location
(locationFileName srcSpanFilename)
(Position srcSpanStartLine srcSpanStartColumn)
(Position srcSpanEndLine srcSpanEndColumn)
where
locationFileName ('.':'/':x) = x
locationFileName x = x
camelize :: String -> String
camelize = concatMap capitalize . words
capitalize :: String -> String
capitalize [] = []
capitalize (c:rest) = toUpper c : rest
-- "The baseline remediation points value is 50,000, which is the time it takes
-- to fix a trivial code style issue like a missing semicolon on a single line,
-- including the time for the developer to open the code, make the change, and
-- confidently commit the fix. All other remediation points values are expressed
-- in multiples of that Basic Remediation Point Value."
basePoints :: Int
basePoints = 50000
hlint-2.0.11/src/Apply.hs 0000644 0000000 0000000 00000010350 13210071537 013305 0 ustar 00 0000000 0000000
module Apply(applyHints, applyHintFile, applyHintFiles) where
import Control.Applicative
import Data.Monoid
import HSE.All
import Hint.All
import Idea
import Data.Tuple.Extra
import Data.Either
import Data.List.Extra
import Data.Maybe
import Data.Ord
import Config.Type
import Config.Haskell
import Prelude
-- | Apply hints to a single file, you may have the contents of the file.
applyHintFile :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO [Idea]
applyHintFile flags s file src = do
res <- parseModuleApply flags s file src
return $ case res of
Left err -> [err]
Right m -> executeHints s [m]
-- | Apply hints to multiple files, allowing cross-file hints to fire.
applyHintFiles :: ParseFlags -> [Setting] -> [FilePath] -> IO [Idea]
applyHintFiles flags s files = do
(err, ms) <- partitionEithers <$> mapM (\file -> parseModuleApply flags s file Nothing) files
return $ err ++ executeHints s ms
-- | Given a way of classifying results, and a 'Hint', apply to a set of modules generating a list of 'Idea's.
-- The 'Idea' values will be ordered within a file.
--
-- Given a set of modules, it may be faster pass each to 'applyHints' in a singleton list.
-- When given multiple modules at once this function attempts to find hints between modules,
-- which is slower and often pointless (by default HLint passes modules singularly, using
-- @--cross@ to pass all modules together).
applyHints {- PUBLIC -} :: [Classify] -> Hint -> [(Module SrcSpanInfo, [Comment])] -> [Idea]
applyHints cs = applyHintsReal $ map SettingClassify cs
applyHintsReal :: [Setting] -> Hint -> [(Module_, [Comment])] -> [Idea]
applyHintsReal settings hints_ ms = concat $
[ map (classify $ cls ++ mapMaybe readPragma (universeBi m)) $
order "" (hintModule hints settings nm m) `merge`
concat [order (fromNamed d) $ decHints d | d <- moduleDecls m] `merge`
concat [order "" $ hintComment hints settings c | c <- cs]
| (nm,(m,cs)) <- mns
, let decHints = hintDecl hints settings nm m -- partially apply
, let order n = map (\i -> i{ideaModule=moduleName m, ideaDecl=n}) . sortBy (comparing ideaSpan)
, let merge = mergeBy (comparing ideaSpan)] ++
[map (classify cls) (hintModules hints settings $ map (second fst) mns)]
where
cls = [x | SettingClassify x <- settings]
mns = map (scopeCreate . fst &&& id) ms
hints = (if length ms <= 1 then noModules else id) hints_
noModules h = h{hintModules = \_ _ -> []} `mappend` mempty{hintModule = \s a b -> hintModules h s [(a,b)]}
-- | Given a list of settings (a way to classify) and a list of hints, run them over a list of modules.
executeHints :: [Setting] -> [(Module_, [Comment])] -> [Idea]
executeHints s = applyHintsReal s (allHints s)
-- | Return either an idea (a parse error) or the module. In IO because might call the C pre processor.
parseModuleApply :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO (Either Idea (Module_, [Comment]))
parseModuleApply flags s file src = do
res <- parseModuleEx (parseFlagsAddFixities [x | Infix x <- s] flags) file src
case res of
Right m -> return $ Right m
Left (ParseError sl msg ctxt) -> do
i <- return $ rawIdeaN Error "Parse error" (mkSrcSpan sl sl) ctxt Nothing []
i <- return $ classify [x | SettingClassify x <- s] i
return $ Left i
-- | Find which hints a list of settings implies.
allHints :: [Setting] -> Hint
allHints xs = mconcat $ hintRules [x | SettingMatchExp x <- xs] : map f builtin
where builtin = nub $ concat [if x == "All" then map fst builtinHints else [x] | Builtin x <- xs]
f x = fromMaybe (error $ "Unknown builtin hints: HLint.Builtin." ++ x) $ lookup x builtinHints
-- | Given some settings, make sure the severity field of the Idea is correct.
classify :: [Classify] -> Idea -> Idea
classify xs i = let s = foldl' (f i) (ideaSeverity i) xs in s `seq` i{ideaSeverity=s}
where
-- figure out if we need to change the severity
f :: Idea -> Severity -> Classify -> Severity
f i r c | classifyHint c ~= ideaHint i && classifyModule c ~= ideaModule i && classifyDecl c ~= ideaDecl i = classifySeverity c
| otherwise = r
x ~= y = null x || x == y
hlint-2.0.11/src/Test/ 0000755 0000000 0000000 00000000000 13210071537 012604 5 ustar 00 0000000 0000000 hlint-2.0.11/src/Test/Util.hs 0000644 0000000 0000000 00000002231 13210071537 014053 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards #-}
module Test.Util(
withTests, tested, passed, failed, progress
) where
import Data.IORef
import System.IO.Unsafe
import Control.Monad
data Result = Result {failures :: Int, total :: Int} deriving Show
{-# NOINLINE ref #-}
ref :: IORef [Result]
ref = unsafePerformIO $ newIORef []
-- | Returns the number of failing tests.
-- Warning: Not multithread safe, but is reenterant
withTests :: IO () -> IO Int
withTests act = do
atomicModifyIORef ref $ \r -> (Result 0 0 : r, ())
act
Result{..} <- atomicModifyIORef ref $ \(r:rs) -> (rs, r)
putStrLn ""
putStrLn $ if failures == 0
then "Tests passed (" ++ show total ++ ")"
else "Tests failed (" ++ show failures ++ " of " ++ show total ++ ")"
return failures
progress :: IO ()
progress = putChar '.'
passed :: IO ()
passed = atomicModifyIORef ref $ \(r:rs) -> (r{total=total r+1}:rs, ())
failed :: [String] -> IO ()
failed xs = do
unless (null xs) $ putStrLn $ unlines $ "" : xs
atomicModifyIORef ref $ \(r:rs) -> (r{total=total r+1, failures=failures r+1}:rs, ())
tested :: Bool -> IO ()
tested b = if b then passed else failed []
hlint-2.0.11/src/Test/Translate.hs 0000644 0000000 0000000 00000011046 13210071537 015077 0 ustar 00 0000000 0000000
-- | Translate the hints to Haskell and run with GHC.
module Test.Translate(testTypeCheck, testQuickCheck) where
import Control.Monad
import Data.List.Extra
import System.IO.Extra
import Data.Maybe
import System.Process
import System.Exit
import System.FilePath
import Config.Type
import HSE.All
import Test.Util
runMains :: FilePath -> FilePath -> [String] -> IO ()
runMains datadir tmpdir xs = (if tmpdir == "" then withTempDir else ($ tmpdir)) $ \dir -> do
ms <- forM (zip [1..] xs) $ \(i,x) -> do
let m = "I" ++ show i
writeFile (dir m <.> "hs") $ replace "module Main" ("module " ++ m) x
return m
writeFile (dir "Main.hs") $ unlines $
["import qualified " ++ m | m <- ms] ++
["main = do"] ++
[" " ++ m ++ ".main" | m <- ms]
res <- 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]] -> IO ()
testTypeCheck = wrap toTypeCheck
-- | Given a set of hints, do all the HintRule hints satisfy QuickCheck
testQuickCheck :: FilePath -> FilePath -> [[Setting]] -> IO ()
testQuickCheck = wrap toQuickCheck
wrap :: ([HintRule] -> [String]) -> FilePath -> FilePath -> [[Setting]] -> IO ()
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 = return ()"] ++
["{-# LINE " ++ show (startLine $ ann rhs) ++ " " ++ show (fileName $ ann rhs) ++ " #-}\n" ++
prettyPrint (PatBind an (toNamed $ "test" ++ show i) bod Nothing)
| (i, HintRule _ _ _ lhs rhs side _) <- zip [1..] hints, "noTypeCheck" `notElem` vars (maybeToList side)
, let vs = map toNamed $ nub $ 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) <- zip [1..] hints, "noQuickCheck" `notElem` vars (maybeToList side)
, let vs = map (restrict side) $ nub $ 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 RemovesError{} = True
isRemovesError _ = False
hlint-2.0.11/src/Test/Proof.hs 0000644 0000000 0000000 00000021231 13210071537 014224 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards, PatternGuards, FlexibleContexts #-}
-- | Check the coverage of the hints given a list of Isabelle theorems
module Test.Proof(proof) where
import Data.Tuple.Extra
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.State
import Data.Char
import Data.List
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 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 = nub $ 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 = 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 ++ " \\ " ++ 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
return $ if b then Paren an $ toNamed $ prettyPrint v ++ "::'a::" ++ cls ++ "_sym" else v
g v = return v :: State Bool Exp_
f _ x = x
relationship hintRuleNotes a b | any lazier hintRuleNotes = a ++ " \\ " ++ b
| DecreasesLaziness `elem` hintRuleNotes = b ++ " \\ " ++ a
| otherwise = a ++ " = " ++ b
where lazier IncreasesLaziness = True
lazier RemovesError{} = True
lazier _ = False
assumes (App _ op var)
| op ~= "isNat" = "le\\0\\" ++ prettyPrint var ++ " \\ FF \\ "
| op ~= "isNegZero" = "gt\\0\\" ++ prettyPrint var ++ " \\ FF \\ "
assumes (App _ op var) | op ~= "isWHNF" = prettyPrint var ++ " \\ \\ \\ "
assumes _ = ""
exp1 = exp . transformBi unqual
-- Syntax translations
exp (App _ a b) = exp a ++ "\\" ++ exp b
exp (Paren _ x) = "(" ++ exp x ++ ")"
exp (Var _ x) | Just x <- funs $ prettyPrint x = x
exp (Con _ (Special _ (TupleCon _ _ i))) = "\\" ++ replicate (i-1) ',' ++ "\\"
exp (Con _ x) | Just x <- cons $ prettyPrint x = x
exp (Tuple _ _ xs) = "\\" ++ intercalate ", " (map exp xs) ++ "\\"
exp (If _ a b c) = "If " ++ exp a ++ " then " ++ exp b ++ " else " ++ exp c
exp (Lambda _ xs y) = "\\ " ++ unwords (map pat xs) ++ ". " ++ exp y
exp (InfixApp _ x op y) | Just op <- ops $ prettyPrint op =
if pre op then op ++ "\\" ++ exp (paren x) ++ "\\" ++ 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) = "\\" ++ intercalate ", " (map pat xs) ++ "\\"
pat x = prettyPrint x
fresh x = head $ ("z":["v" ++ show i | i <- [1..]]) \\ vars x
hlint-2.0.11/src/Test/InputOutput.hs 0000644 0000000 0000000 00000007723 13210071537 015471 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards, ViewPatterns #-}
-- | Check the input/output pairs in the tests/ directory
module Test.InputOutput(testInputOutput) where
import Control.Applicative
import Data.Tuple.Extra
import Control.Exception
import Control.Monad
import Data.List.Extra
import Data.IORef
import System.Directory
import System.FilePath
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Verbosity
import System.Exit
import System.IO.Extra
import Prelude
import Test.Util
testInputOutput :: ([String] -> IO ()) -> IO ()
testInputOutput main = do
xs <- getDirectoryContents "tests"
xs <- return $ filter ((==) ".test" . takeExtension) xs
forM_ xs $ \file -> do
ios <- parseInputOutputs <$> readFile ("tests" file)
forM_ (zip [1..] ios) $ \(i,io@InputOutput{..}) -> do
progress
forM_ files $ \(name,contents) -> do
createDirectoryIfMissing True $ takeDirectory name
writeFile name contents
checkInputOutput main io{name= "_" ++ takeBaseName file ++ "_" ++ show i}
mapM_ (removeFile . fst) $ concatMap files ios
data InputOutput = InputOutput
{name :: String
,files :: [(FilePath, String)]
,run :: [String]
,output :: String
,exit :: Maybe ExitCode
} deriving Eq
parseInputOutputs :: String -> [InputOutput]
parseInputOutputs = f z . lines
where
z = InputOutput "unknown" [] [] "" Nothing
interest x = any (`isPrefixOf` x) ["----","FILE","RUN","OUTPUT","EXIT"]
f io ((stripPrefix "RUN " -> Just flags):xs) = f io{run = splitArgs flags} xs
f io ((stripPrefix "EXIT " -> Just code):xs) = f io{exit = Just $ let i = read code in if i == 0 then ExitSuccess else ExitFailure i} xs
f io ((stripPrefix "FILE " -> Just file):xs) | (str,xs) <- g xs = f io{files = files io ++ [(file,unlines str)]} xs
f io ("OUTPUT":xs) | (str,xs) <- g xs = f io{output = unlines str} xs
f io ((isPrefixOf "----" -> True):xs) = [io | io /= z] ++ f z xs
f io [] = [io | io /= z]
f io (x:xs) = error $ "Unknown test item, " ++ x
g = first (reverse . dropWhile null . reverse) . break interest
---------------------------------------------------------------------
-- CHECK INPUT/OUTPUT PAIRS
checkInputOutput :: ([String] -> IO ()) -> InputOutput -> IO ()
checkInputOutput main InputOutput{..} = do
code <- newIORef ExitSuccess
got <- fmap (reverse . dropWhile null . reverse . map trimEnd . lines . fst) $ captureOutput $
handle (\(e::SomeException) -> print e) $
handle (\(e::ExitCode) -> writeIORef code e) $
bracket getVerbosity setVerbosity $ const $ setVerbosity Normal >> main run
code <- readIORef code
(want,got) <- return $ matchStarStar (lines output) got
if maybe False (/= code) exit then
failed
["TEST FAILURE IN tests/" ++ name
,"WRONG EXIT CODE"
,"GOT : " ++ show code
,"WANT: " ++ show exit
]
else if length got == length want && and (zipWith matchStar want got) then
passed
else do
let trail = replicate (max (length got) (length want)) ""
let (i,g,w):_ = [(i,g,w) | (i,g,w) <- zip3 [1..] (got++trail) (want++trail), not $ matchStar w g]
failed $
["TEST FAILURE IN tests/" ++ name
,"DIFFER ON LINE: " ++ show i
,"GOT : " ++ g
,"WANT: " ++ w
,"FULL OUTPUT FOR GOT:"] ++ got
-- | First string may have stars in it (the want)
matchStar :: String -> String -> Bool
matchStar ('*':xs) ys = any (matchStar xs) $ tails ys
matchStar (x:xs) (y:ys) = x == y && matchStar xs ys
matchStar [] [] = True
matchStar _ _ = False
matchStarStar :: [String] -> [String] -> ([String], [String])
matchStarStar want got = case break (== "**") want of
(_, []) -> (want, got)
(w1,_:w2) -> (w1++w2, g1 ++ takeEnd (length w2) g2)
where (g1,g2) = splitAt (length w1) got
hlint-2.0.11/src/Test/Annotations.hs 0000644 0000000 0000000 00000006130 13210071537 015435 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, RecordWildCards #-}
-- | Check the annotations within source and hint files.
module Test.Annotations(testAnnotations) where
import Data.Tuple.Extra
import Data.Char
import Data.List.Extra
import Data.Maybe
import Data.Function
import Config.Type
import Idea
import Apply
import HSE.All
import Test.Util
-- Input, Output
-- Output = Nothing, should not match
-- Output = Just xs, should match xs
data Test = Test SrcLoc String (Maybe String)
testAnnotations :: [Setting] -> FilePath -> IO ()
testAnnotations setting file = do
tests <- parseTestFile file
mapM_ f tests
where
f (Test loc inp out) = do
ideas <- applyHintFile defaultParseFlags setting file $ Just inp
let good = case out of
Nothing -> null ideas
Just x -> length ideas == 1 &&
seq (length (show ideas)) True && -- force, mainly for hpc
match x (head ideas)
let bad =
[failed $
["TEST FAILURE (" ++ show (length ideas) ++ " hints generated)"
,"SRC: " ++ showSrcLoc loc
,"INPUT: " ++ inp] ++
map ((++) "OUTPUT: " . show) ideas ++
["WANTED: " ++ fromMaybe "" out]
| not good] ++
[failed
["TEST FAILURE (BAD LOCATION)"
,"SRC: " ++ showSrcLoc loc
,"INPUT: " ++ inp
,"OUTPUT: " ++ show i]
| i@Idea{..} <- ideas, let SrcLoc{..} = getPointLoc ideaSpan, srcFilename == "" || srcLine == 0 || srcColumn == 0]
if null bad then passed else sequence_ bad
match "???" _ = True
match x y | "@" `isPrefixOf` x = a == show (ideaSeverity y) && match (trimStart b) y
where (a,b) = break isSpace $ tail x
match x y = on (==) norm (fromMaybe "" $ ideaTo y) x
-- FIXME: Should use a better check for expected results
norm = filter $ \x -> not (isSpace x) && x /= ';'
parseTestFile :: FilePath -> IO [Test]
parseTestFile file = do
src <- readFile file
-- we remove all leading # symbols since Yaml only lets us do comments that way
return $ f False $ zip [1..] $ map (\x -> fromMaybe x $ stripPrefix "# " x) $ lines src
where
open = isPrefixOf ""
shut = isPrefixOf ""
f False ((i,x):xs) = f (open x) xs
f True ((i,x):xs)
| shut x = f False xs
| null x || "-- " `isPrefixOf` x = f True xs
| "\\" `isSuffixOf` x, (_,y):ys <- xs = f True $ (i,init x++"\n"++y):ys
| otherwise = parseTest file i x : f True xs
f _ [] = []
parseTest file i x = uncurry (Test (SrcLoc file i 0)) $ f x
where
f x | Just x <- stripPrefix "" x = first ("--"++) $ f x
f (' ':'-':'-':xs) | null xs || " " `isPrefixOf` xs = ("", Just $ dropWhile isSpace xs)
f (x:xs) = first (x:) $ f xs
f [] = ([], Nothing)
hlint-2.0.11/src/Test/All.hs 0000644 0000000 0000000 00000005611 13210071537 013653 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module Test.All(test) where
import Control.Exception
import Control.Monad
import Data.Char
import Data.List
import System.Directory
import System.FilePath
import Data.Functor
import Prelude
import Config.Type
import Config.Read
import CmdLine
import HSE.All
import Hint.All
import Test.Util
import Test.InputOutput
import Test.Annotations
import Test.Translate
import System.IO.Extra
test :: Cmd -> ([String] -> IO ()) -> FilePath -> [FilePath] -> IO Int
test CmdTest{..} main dataDir files = withBuffering stdout NoBuffering $ withTests $ do
hasSrc <- doesFileExist "hlint.cabal"
useSrc <- return $ hasSrc && null files
testFiles <- if files /= [] then return files else do
xs <- getDirectoryContents dataDir
return [dataDir x | x <- xs, takeExtension x `elem` [".hs",".yml",".yaml"]
, not $ "HLint_" `isPrefixOf` takeBaseName x]
testFiles <- forM testFiles $ \file -> do
hints <- readFilesConfig [(file, Nothing)]
return (file, hints ++ (if takeBaseName file /= "Test" then [] else map (Builtin . fst) builtinHints))
let wrap msg act = putStr (msg ++ " ") >> act >> putStrLn ""
putStrLn "Testing"
checkCommentedYaml $ dataDir "default.yaml"
config <- readFilesConfig [(".hlint.yaml",Nothing)]
when useSrc $ wrap "Source annotations" $
forM_ builtinHints $ \(name,_) -> do
progress
testAnnotations (Builtin name : if name == "Restrict" then config else []) $ "src/Hint" name <.> "hs"
when useSrc $ wrap "Input/outputs" $ testInputOutput main
wrap "Hint names" $ mapM_ (\x -> do progress; testNames $ snd x) testFiles
wrap "Hint annotations" $ forM_ testFiles $ \(file,h) -> do progress; testAnnotations h file
when cmdTypeCheck $ wrap "Hint typechecking" $
progress >> testTypeCheck cmdDataDir cmdTempDir [h | (file, h) <- testFiles, takeFileName file /= "Test.hs"]
when cmdQuickCheck $ wrap "Hint QuickChecking" $
progress >> testQuickCheck cmdDataDir cmdTempDir [h | (file, h) <- testFiles, takeFileName file /= "Test.hs"]
when (null files && not hasSrc) $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped"
---------------------------------------------------------------------
-- VARIOUS SMALL TESTS
testNames :: [Setting] -> IO ()
testNames hints = sequence_
[ failed ["No name for the hint " ++ prettyPrint hintRuleLHS ++ " ==> " ++ prettyPrint hintRuleRHS]
| SettingMatchExp x@HintRule{..} <- hints, hintRuleName == defaultHintName]
checkCommentedYaml :: FilePath -> IO ()
checkCommentedYaml file = do
src <- lines <$> readFile' file
let src2 = [x | x <- src, Just x <- [stripPrefix "# " x], not $ all (\x -> isAlpha x || x == '$') $ take 1 x]
e <- readFilesConfig [(file, Just $ unlines src2)]
void $ evaluate $ length e
hlint-2.0.11/src/Language/ 0000755 0000000 0000000 00000000000 13210071537 013410 5 ustar 00 0000000 0000000 hlint-2.0.11/src/Language/Haskell/ 0000755 0000000 0000000 00000000000 13210071537 014773 5 ustar 00 0000000 0000000 hlint-2.0.11/src/Language/Haskell/HLint3.hs 0000644 0000000 0000000 00000012046 13210071537 016433 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, RecordWildCards #-}
-- | /WARNING: This module represents the evolving second version of the HLint API./
-- /It will be renamed to drop the "3" in the next major version./
--
-- This module provides a way to apply HLint hints. If you want to just run @hlint@ in-process
-- and collect the results see 'hlint'. If you want to approximate the @hlint@ experience with
-- a more structured API try:
--
-- @
-- (flags, classify, hint) <- 'autoSettings'
-- Right m <- 'parseModuleEx' flags \"MyFile.hs\" Nothing
-- print $ 'applyHints' classify hint [m]
-- @
module Language.Haskell.HLint3(
hlint, applyHints,
-- * Idea data type
Idea(..), Severity(..), Note(..),
-- * Settings
Classify(..),
getHLintDataDir, autoSettings, argsSettings,
findSettings, readSettingsFile,
-- * Hints
HintBuiltin(..), HintRule(..),
Hint(..), resolveHints,
-- * Scopes
Scope, scopeCreate, scopeMatch, scopeMove,
-- * Haskell-src-exts
parseModuleEx, defaultParseFlags, parseFlagsAddFixities, ParseError(..), ParseFlags(..), CppFlags(..)
) where
import Config.Type
import Config.Read
import Idea
import Apply
import HLint
import HSE.All
import Hint.All
import CmdLine
import Paths_hlint
import Data.List.Extra
import Data.Maybe
import System.FilePath
-- | Get the Cabal configured data directory of HLint.
getHLintDataDir :: IO FilePath
getHLintDataDir = getDataDir
-- | The function produces a tuple containg 'ParseFlags' (for 'parseModuleEx'),
-- and 'Classify' and 'Hint' for 'applyHints'.
-- It approximates the normal HLint configuration steps, roughly:
--
-- 1. Use 'findSettings' with 'readSettingsFile' to find and load the HLint settings files.
--
-- 1. Use 'parseFlagsAddFixities' and 'resolveHints' to transform the outputs of 'findSettings'.
--
-- If you want to do anything custom (e.g. using a different data directory, storing intermediate outputs,
-- loading hints from a database) you are expected to copy and paste this function, then change it to your needs.
autoSettings :: IO (ParseFlags, [Classify], Hint)
autoSettings = do
(fixities, classify, hints) <- findSettings (readSettingsFile Nothing) Nothing
return (parseFlagsAddFixities fixities defaultParseFlags, classify, resolveHints hints)
-- | A version of 'autoSettings' which respects some of the arguments supported by HLint.
-- If arguments unrecognised by HLint are used it will result in an error.
-- 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: Two things that could be supported (but aren't) are 'cmdGivenHints' and 'cmdWithHints'.
(_,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]
return (flags, classify ++ ignore, resolveHints hints)
_ -> error "Can only invoke autoSettingsArgs with the root process"
-- | Given a directory (or 'Nothing' to imply 'getHLintDataDir'), and a module name
-- (e.g. @HLint.Default@), find the settings file associated with it, returning the
-- name of the file, and (optionally) the contents.
--
-- This function looks for all settings files starting with @HLint.@ in the directory
-- argument, and all other files relative to the current directory.
readSettingsFile :: Maybe FilePath -> String -> IO (FilePath, Maybe String)
readSettingsFile dir x
| takeExtension x `elem` [".yml",".yaml"] = do
dir <- maybe getHLintDataDir return dir
return (dir x, Nothing)
| Just x <- "HLint." `stripPrefix` x = do
dir <- maybe getHLintDataDir return dir
return (dir x <.> "hs", Nothing)
| otherwise = return (x <.> "hs", Nothing)
-- | Given a function to load a module (typically 'readSettingsFile'), and a module to start from
-- (defaults to @hlint.yaml@) find the information from all settings files.
findSettings :: (String -> IO (FilePath, Maybe String)) -> Maybe String -> IO ([Fixity], [Classify], [Either HintBuiltin HintRule])
findSettings load start = do
(file,contents) <- load $ fromMaybe "hlint.yaml" start
xs <- readFilesConfig [(file,contents)]
return $ splitSettings xs
-- | Split a list of 'Setting' for separate use in parsing and hint resolution
splitSettings :: [Setting] -> ([Fixity], [Classify], [Either HintBuiltin HintRule])
splitSettings xs =
([x | Infix x <- xs]
,[x | SettingClassify x <- xs]
,[Right x | SettingMatchExp x <- xs] ++ map Left [minBound..maxBound])
-- | Snippet from the documentation, if this changes, update the documentation
_docs :: IO ()
_docs = do
(flags, classify, hint) <- autoSettings
Right m <- parseModuleEx flags "MyFile.hs" Nothing
print $ applyHints classify hint [m]
hlint-2.0.11/src/Language/Haskell/HLint.hs 0000644 0000000 0000000 00000002673 13210071537 016355 0 ustar 00 0000000 0000000 {-|
/WARNING: This module represents the old version of the HLint API./
/It will be deleted in favour of "Language.Haskell.HLint3" in the next major version./
This module provides a library interface to HLint, strongly modelled on the command line interface.
-}
module Language.Haskell.HLint(hlint, Suggestion, suggestionLocation, suggestionSeverity, Severity(..)) where
import qualified HLint
import Config.Type
import Idea
import HSE.All
-- | This function takes a list of command line arguments, and returns the given suggestions.
-- To see a list of arguments type @hlint --help@ at the console.
-- This function writes to the stdout/stderr streams, unless @--quiet@ is specified.
--
-- As an example:
--
-- > do hints <- hlint ["src", "--ignore=Use map","--quiet"]
-- > when (length hints > 3) $ error "Too many hints!"
hlint :: [String] -> IO [Suggestion]
hlint = fmap (map Suggestion_) . HLint.hlint
-- | A suggestion - the @Show@ instance is of particular use.
newtype Suggestion = Suggestion_ {fromSuggestion :: Idea}
deriving (Eq,Ord)
instance Show Suggestion where
show = show . fromSuggestion
-- | From a suggestion, extract the file location it refers to.
suggestionLocation :: Suggestion -> SrcLoc
suggestionLocation = getPointLoc . ideaSpan . fromSuggestion
-- | From a suggestion, determine how severe it is.
suggestionSeverity :: Suggestion -> Severity
suggestionSeverity = ideaSeverity . fromSuggestion
hlint-2.0.11/src/HSE/ 0000755 0000000 0000000 00000000000 13210071537 012304 5 ustar 00 0000000 0000000 hlint-2.0.11/src/HSE/Util.hs 0000644 0000000 0000000 00000024376 13210071537 013571 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts, ViewPatterns #-}
module HSE.Util(module HSE.Util, def) where
import Control.Monad
import Data.Default
import Data.List
import Language.Haskell.Exts.Util() -- Orphan instances of Default for SrcLoc etc
import Data.Maybe
import Data.Data hiding (Fixity)
import System.FilePath
import HSE.Type
import Data.Functor
import Prelude
---------------------------------------------------------------------
-- ACCESSOR/TESTER
ellipses :: QName S
ellipses = UnQual an $ Ident an "..." -- Must be an Ident, not a Symbol
opExp :: QOp S -> Exp_
opExp (QVarOp s op) = Var s op
opExp (QConOp s op) = Con s op
expOp :: Exp_ -> Maybe (QOp S)
expOp (Var s op) = Just $ QVarOp s op
expOp (Con s op) = Just $ QConOp s op
expOp _ = Nothing
moduleDecls :: Module_ -> [Decl_]
moduleDecls (Module _ _ _ _ xs) = xs
moduleDecls _ = [] -- XmlPage/XmlHybrid
moduleName :: Module_ -> String
moduleName (Module _ Nothing _ _ _) = "Main"
moduleName (Module _ (Just (ModuleHead _ (ModuleName _ x) _ _)) _ _ _) = x
moduleName _ = "" -- XmlPage/XmlHybrid
moduleImports :: Module_ -> [ImportDecl S]
moduleImports (Module _ _ _ x _) = x
moduleImports _ = [] -- XmlPage/XmlHybrid
modulePragmas :: Module_ -> [ModulePragma S]
modulePragmas (Module _ _ x _ _) = x
modulePragmas _ = [] -- XmlPage/XmlHybrid
fromModuleName :: ModuleName S -> String
fromModuleName (ModuleName _ x) = x
fromChar :: Exp_ -> Maybe Char
fromChar (Lit _ (Char _ x _)) = Just x
fromChar _ = Nothing
fromPChar :: Pat_ -> Maybe Char
fromPChar (PLit _ _ (Char _ x _)) = Just x
fromPChar _ = Nothing
fromString :: Exp_ -> Maybe String
fromString (Lit _ (String _ x _)) = Just x
fromString _ = Nothing
fromPString :: Pat_ -> Maybe String
fromPString (PLit _ _ (String _ x _)) = Just x
fromPString _ = Nothing
fromParen :: Exp_ -> Exp_
fromParen (Paren _ x) = fromParen x
fromParen x = x
fromPParen :: Pat s -> Pat s
fromPParen (PParen _ x) = fromPParen x
fromPParen x = x
fromTyParen :: Type s -> Type s
fromTyParen (TyParen _ x) = fromTyParen x
fromTyParen x = x
fromTyBang :: Type s -> Type s
fromTyBang (TyBang _ _ _ x) = x
fromTyBang x = x
fromDeriving :: Deriving s -> [InstRule s]
fromDeriving (Deriving _ x) = x
-- is* :: Exp_ -> Bool
-- is* :: Decl_ -> Bool
isVar Var{} = True; isVar _ = False
isCon Con{} = True; isCon _ = False
isApp App{} = True; isApp _ = False
isInfixApp InfixApp{} = True; isInfixApp _ = False
isAnyApp x = isApp x || isInfixApp x
isParen Paren{} = True; isParen _ = False
isIf If{} = True; isIf _ = False
isLambda Lambda{} = True; isLambda _ = False
isMDo MDo{} = True; isMDo _ = False
isBoxed Boxed{} = True; isBoxed _ = False
isDerivDecl DerivDecl{} = True; isDerivDecl _ = False
isPBangPat PBangPat{} = True; isPBangPat _ = False
isPFieldPun PFieldPun{} = True; isPFieldPun _ = False
isFieldPun FieldPun{} = True; isFieldPun _ = False
isPWildCard PWildCard{} = True; isPWildCard _ = False
isPFieldWildcard PFieldWildcard{} = True; isPFieldWildcard _ = False
isFieldWildcard FieldWildcard{} = True; isFieldWildcard _ = False
isPViewPat PViewPat{} = True; isPViewPat _ = False
isParComp ParComp{} = True; isParComp _ = False
isTypeApp TypeApp{} = True; isTypeApp _ = False
isPatTypeSig PatTypeSig{} = True; isPatTypeSig _ = False
isQuasiQuote QuasiQuote{} = True; isQuasiQuote _ = False
isTyQuasiQuote TyQuasiQuote{} = True; isTyQuasiQuote _ = False
isSpliceDecl SpliceDecl{} = True; isSpliceDecl _ = False
isNewType NewType{} = True; isNewType _ = False
isRecStmt RecStmt{} = True; isRecStmt _ = False
isClsDefSig ClsDefSig{} = True; isClsDefSig _ = False
isTyBang TyBang{} = True; isTyBang _ = False
isLCase LCase{} = True; isLCase _ = False
isTupleSection TupleSection{} = True; isTupleSection _ = False
isString String{} = True; isString _ = False
isSection LeftSection{} = True
isSection RightSection{} = True
isSection _ = False
isPrimLiteral PrimInt{} = True
isPrimLiteral PrimWord{} = True
isPrimLiteral PrimFloat{} = True
isPrimLiteral PrimDouble{} = True
isPrimLiteral PrimChar{} = True
isPrimLiteral PrimString{} = True
isPrimLiteral _ = False
allowRightSection x = x `notElem` ["-","#"]
allowLeftSection x = x /= "#"
unqual :: QName S -> QName S
unqual (Qual an _ x) = UnQual an x
unqual x = x
fromQual :: QName a -> Maybe (Name a)
fromQual (Qual _ _ x) = Just x
fromQual (UnQual _ x) = Just x
fromQual _ = Nothing
isSpecial :: QName S -> Bool
isSpecial Special{} = True; isSpecial _ = False
isDol :: QOp S -> Bool
isDol (QVarOp _ (UnQual _ (Symbol _ "$"))) = True
isDol _ = False
isDot :: QOp S -> Bool
isDot (QVarOp _ (UnQual _ (Symbol _ "."))) = True
isDot _ = False
isDotApp :: Exp_ -> Bool
isDotApp (InfixApp _ _ dot _) | isDot dot = True
isDotApp _ = False
dotApp :: Exp_ -> Exp_ -> Exp_
dotApp x = InfixApp an x (QVarOp an $ UnQual an $ Symbol an ".")
dotApps :: [Exp_] -> Exp_
dotApps [] = error "HSE.Util.dotApps, does not work on an empty list"
dotApps [x] = x
dotApps (x:xs) = dotApp x (dotApps xs)
isLexeme Var{} = True
isLexeme Con{} = True
isLexeme Lit{} = True
isLexeme _ = False
isAssocLeft AssocLeft{} = True; isAssocLeft _ = False
isAssocNone AssocNone{} = True; isAssocNone _ = False
isWHNF :: Exp_ -> Bool
isWHNF Con{} = True
isWHNF (Lit _ x) = case x of String{} -> False; Int{} -> False; Frac{} -> False; _ -> True
isWHNF Lambda{} = True
isWHNF Tuple{} = True
isWHNF List{} = True
isWHNF (Paren _ x) = isWHNF x
isWHNF (ExpTypeSig _ x _) = isWHNF x
-- other (unknown) constructors may have bang patterns in them, so approximate
isWHNF (App _ c@Con{} _) | prettyPrint c `elem` ["Just","Left","Right"] = True
isWHNF _ = False
---------------------------------------------------------------------
-- HSE FUNCTIONS
isKindHash :: Type_ -> Bool
isKindHash (TyParen _ x) = isKindHash x
isKindHash (TyApp _ x _) = isKindHash x
isKindHash (TyCon _ (fromQual -> Just (Ident _ s))) = "#" `isSuffixOf` s
isKindHash _ = False
getEquations :: Decl s -> [Decl s]
getEquations (FunBind s xs) = map (FunBind s . (:[])) xs
getEquations x@PatBind{} = [toFunBind x]
getEquations x = [x]
toFunBind :: Decl s -> Decl s
toFunBind (PatBind s (PVar _ name) bod bind) = FunBind s [Match s name [] bod bind]
toFunBind x = x
-- case and if both have branches, nothing else does
replaceBranches :: Exp s -> ([Exp s], [Exp s] -> Exp s)
replaceBranches (If s a b c) = ([b,c], \[b,c] -> If s a b c)
replaceBranches (Case s a bs) = (concatMap f bs, Case s a . g bs)
where
f (Alt _ _ (UnGuardedRhs _ x) _) = [x]
f (Alt _ _ (GuardedRhss _ xs) _) = [x | GuardedRhs _ _ x <- xs]
g (Alt s1 a (UnGuardedRhs s2 _) b:rest) (x:xs) = Alt s1 a (UnGuardedRhs s2 x) b : g rest xs
g (Alt s1 a (GuardedRhss s2 ns) b:rest) xs =
Alt s1 a (GuardedRhss s2 [GuardedRhs a b x | (GuardedRhs a b _,x) <- zip ns as]) b : g rest bs
where (as,bs) = splitAt (length ns) xs
g [] [] = []
g _ _ = error "HSE.Util.replaceBranches: internal invariant failed, lists are of differing lengths"
replaceBranches x = ([], \[] -> x)
---------------------------------------------------------------------
-- VECTOR APPLICATION
apps :: [Exp_] -> Exp_
apps = foldl1 (App an)
fromApps :: Exp_ -> [Exp_]
fromApps = map fst . fromAppsWithLoc
fromAppsWithLoc :: Exp_ -> [(Exp_, S)]
fromAppsWithLoc (App l x y) = fromAppsWithLoc x ++ [(y, l)]
fromAppsWithLoc x = [(x, ann x)]
-- Rule for the Uniplate Apps functions
-- Given (f a) b, consider the children to be: children f ++ [a,b]
childrenApps :: Exp_ -> [Exp_]
childrenApps (App s x y) = childrenApps x ++ [y]
childrenApps x = children x
descendApps :: (Exp_ -> Exp_) -> Exp_ -> Exp_
descendApps f (App s x y) = App s (descendApps f x) (f y)
descendApps f x = descend f x
descendAppsM :: Monad m => (Exp_ -> m Exp_) -> Exp_ -> m Exp_
descendAppsM f (App s x y) = liftM2 (App s) (descendAppsM f x) (f y)
descendAppsM f x = descendM f x
universeApps :: Exp_ -> [Exp_]
universeApps x = x : concatMap universeApps (childrenApps x)
transformApps :: (Exp_ -> Exp_) -> Exp_ -> Exp_
transformApps f = f . descendApps (transformApps f)
transformAppsM :: Monad m => (Exp_ -> m Exp_) -> Exp_ -> m Exp_
transformAppsM f x = f =<< descendAppsM (transformAppsM f) x
---------------------------------------------------------------------
-- UNIPLATE FUNCTIONS
universeS :: (Data x, Data (f S)) => x -> [f S]
universeS = universeBi
childrenS :: (Data x, Data (f S)) => x -> [f S]
childrenS = childrenBi
-- return the parent along with the child
universeParentExp :: Data a => a -> [(Maybe (Int, Exp_), Exp_)]
universeParentExp xs = concat [(Nothing, x) : f x | x <- childrenBi xs]
where f p = concat [(Just (i,p), c) : f c | (i,c) <- zip [0..] $ children p]
---------------------------------------------------------------------
-- SRCLOC FUNCTIONS
showSrcLoc :: SrcLoc -> String
showSrcLoc (SrcLoc file line col) = take 1 file ++ f (drop 1 file) ++ ":" ++ show line ++ ":" ++ show col
where f (x:y:zs) | isPathSeparator x && isPathSeparator y = f $ x:zs
f (x:xs) = x : f xs
f [] = []
an :: SrcSpanInfo
an = def
dropAnn :: Functor f => f SrcSpanInfo -> f ()
dropAnn = void
---------------------------------------------------------------------
-- SRCLOC EQUALITY
-- enforce all being on S, as otherwise easy to =~= on a Just, and get the wrong functor
x /=~= y = not $ x =~= y
elem_, notElem_ :: (Annotated f, Eq (f ())) => f S -> [f S] -> Bool
elem_ x = any (x =~=)
notElem_ x = not . elem_ x
nub_ :: (Annotated f, Eq (f ())) => [f S] -> [f S]
nub_ = nubBy (=~=)
delete_ :: (Annotated f, Eq (f ())) => f S -> [f S] -> [f S]
delete_ = deleteBy (=~=)
intersect_ :: (Annotated f, Eq (f ())) => [f S] -> [f S] -> [f S]
intersect_ = intersectBy (=~=)
eqList, neqList :: (Annotated f, Eq (f ())) => [f S] -> [f S] -> Bool
neqList x y = not $ eqList x y
eqList (x:xs) (y:ys) = x =~= y && eqList xs ys
eqList [] [] = True
eqList _ _ = False
eqMaybe:: (Annotated f, Eq (f ())) => Maybe (f S) -> Maybe (f S) -> Bool
eqMaybe (Just x) (Just y) = x =~= y
eqMaybe Nothing Nothing = True
eqMaybe _ _ = False
---------------------------------------------------------------------
-- FIXITIES
getFixity :: Decl a -> [Fixity]
getFixity (InfixDecl sl a mp ops) = [Fixity (void a) (fromMaybe 9 mp) (UnQual () $ void $ f op) | op <- ops]
where f (VarOp _ x) = x
f (ConOp _ x) = x
getFixity _ = []
toInfixDecl :: Fixity -> Decl ()
toInfixDecl (Fixity a b c) = InfixDecl () a (Just b) $ maybeToList $ VarOp () <$> fromQual c
hlint-2.0.11/src/HSE/Unify.hs 0000644 0000000 0000000 00000010673 13210071537 013741 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables #-}
module HSE.Unify(
Subst, fromSubst,
validSubst, substitute,
unifyExp,
) where
import Control.Applicative
import Data.List.Extra
import Data.Maybe
import Data.Data
import Data.Monoid
import Config.Type
import Hint.Type
import Control.Monad
import Data.Tuple.Extra
import Util
import Prelude
---------------------------------------------------------------------
-- SUBSTITUTION DATA TYPE
-- | A list of substitutions. A key may be duplicated, you need to call 'check'
-- to ensure the substitution is valid.
newtype Subst a = Subst [(String, a)]
-- | Unpack the substitution
fromSubst :: Subst a -> [(String, a)]
fromSubst (Subst xs) = xs
instance Functor Subst where
fmap f (Subst xs) = Subst $ map (second f) xs
instance Pretty a => Show (Subst a) where
show (Subst xs) = unlines [a ++ " = " ++ prettyPrint b | (a,b) <- xs]
instance Monoid (Subst a) where
mempty = Subst []
mappend (Subst xs) (Subst ys) = Subst $ xs ++ ys
-- check the unification is valid and simplify it
validSubst :: (a -> a -> Bool) -> Subst a -> Maybe (Subst a)
validSubst eq = fmap Subst . mapM f . groupSort . fromSubst
where f (x,y:ys) | all (eq y) ys = Just (x,y)
f _ = Nothing
-- | Perform a substitution
substitute :: Subst Exp_ -> Exp_ -> Exp_
substitute (Subst bind) = transformBracket exp . transformBi pat
where
exp (Var _ (fromNamed -> x)) = lookup x bind
exp _ = Nothing
pat (PVar _ (fromNamed -> x)) | Just y <- lookup x bind = toNamed $ fromNamed y
pat x = x :: Pat_
---------------------------------------------------------------------
-- UNIFICATION
type NameMatch = QName S -> QName S -> Bool
nmOp :: NameMatch -> QOp S -> QOp S -> Bool
nmOp nm (QVarOp _ x) (QVarOp _ y) = nm x y
nmOp nm (QConOp _ x) (QConOp _ y) = nm x y
nmOp nm _ _ = False
-- | Unification, obeys the property that if @unify a b = s@, then @substitute s a = b@.
unify :: Data a => NameMatch -> Bool -> a -> a -> Maybe (Subst Exp_)
unify nm root x y
| Just (x,y) <- cast (x,y) = unifyExp nm root x y
| Just (x,y) <- cast (x,y) = unifyPat nm x y
| Just (x :: S) <- cast x = Just mempty
| otherwise = unifyDef nm x y
unifyDef :: Data a => NameMatch -> a -> a -> Maybe (Subst Exp_)
unifyDef nm x y = fmap mconcat . sequence =<< gzip (unify nm False) x y
-- App/InfixApp are analysed specially for performance reasons
-- root = True, this is the outside of the expr
-- do not expand out a dot at the root, since otherwise you get two matches because of readRule (Bug #570)
unifyExp :: NameMatch -> Bool -> Exp_ -> Exp_ -> Maybe (Subst Exp_)
unifyExp nm root x y | isParen x || isParen y =
fmap (rebracket y) <$> unifyExp nm root (fromParen x) (fromParen y)
where
rebracket (Paren l e') e | e' == e = Paren l e
rebracket e e' = e'
unifyExp nm root (Var _ (fromNamed -> v)) y | isUnifyVar v = Just $ Subst [(v,y)]
unifyExp nm root (Var _ x) (Var _ y) | nm x y = Just mempty
-- Options: match directly, and expand through .
unifyExp nm root x@(App _ x1 x2) (App _ y1 y2) =
liftM2 (<>) (unifyExp nm False x1 y1) (unifyExp nm False x2 y2) `mplus`
(do guard $ not root
-- don't expand . if at the root, otherwise you can get duplicate matches
-- because the matching engine auto-generates hints in dot-form
InfixApp _ y11 dot y12 <- return $ fromParen y1
guard $ isDot dot
unifyExp nm root x (App an y11 (App an y12 y2)))
-- Options: match directly, then expand through $, then desugar infix
unifyExp nm root x (InfixApp _ lhs2 op2 rhs2)
| InfixApp _ lhs1 op1 rhs1 <- x = guard (nmOp nm op1 op2) >> liftM2 (<>) (unifyExp nm False lhs1 lhs2) (unifyExp nm False rhs1 rhs2)
| isDol op2 = unifyExp nm root x $ App an lhs2 rhs2
| otherwise = unifyExp nm root x $ App an (App an (opExp op2) lhs2) rhs2
unifyExp nm root x y | isOther x, isOther y = unifyDef nm x y
where
-- types that are not already handled in unify
{-# INLINE isOther #-}
isOther Var{} = False
isOther App{} = False
isOther InfixApp{} = False
isOther _ = True
unifyExp nm root _ _ = Nothing
unifyPat :: NameMatch -> Pat_ -> Pat_ -> Maybe (Subst Exp_)
unifyPat nm (PVar _ x) (PVar _ y) = Just $ Subst [(fromNamed x, toNamed $ fromNamed y)]
unifyPat nm (PVar _ x) PWildCard{} = Just $ Subst [(fromNamed x, toNamed $ "_" ++ fromNamed x)]
unifyPat nm x y = unifyDef nm x y
hlint-2.0.11/src/HSE/Type.hs 0000644 0000000 0000000 00000000755 13210071537 013570 0 ustar 00 0000000 0000000
module HSE.Type(
S,
Module_, Decl_, Exp_, Pat_, Type_,
module HSE,
module Uniplate
) where
-- Almost all from the Annotated module, but the fixity resolution from Annotated
-- uses the unannotated Assoc enumeration, so export that instead
import Language.Haskell.Exts as HSE hiding (parse, loc, paren)
import Data.Generics.Uniplate.Data as Uniplate
type S = SrcSpanInfo
type Module_ = Module S
type Decl_ = Decl S
type Exp_ = Exp S
type Pat_ = Pat S
type Type_ = Type S
hlint-2.0.11/src/HSE/Scope.hs 0000644 0000000 0000000 00000007326 13210071537 013721 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns #-}
module HSE.Scope(
Scope, scopeCreate, scopeImports,
scopeMatch, scopeMove
) where
import Data.Monoid
import HSE.Type
import HSE.Util
import Data.List
import Data.Maybe
import Prelude
{-
the hint file can do:
import Prelude (filter)
import Data.List (filter)
import List (filter)
then filter on it's own will get expanded to all of them
import Data.List
import List as Data.List
if Data.List.head x ==> x, then that might match List too
-}
-- | Data type representing the modules in scope within a module.
-- Created with 'scopeCreate' and queried with 'scopeMatch' and 'scopeMove'.
-- Note that the 'mempty' 'Scope' is not equivalent to 'scopeCreate' on an empty module,
-- due to the implicit import of 'Prelude'.
newtype Scope = Scope [ImportDecl S]
deriving Show
instance Monoid Scope where
mempty = Scope []
mappend (Scope xs) (Scope ys) = Scope $ xs ++ ys
-- | Create a 'Scope' value from a module, based on the modules imports.
scopeCreate :: Module SrcSpanInfo -> Scope
scopeCreate xs = Scope $ [prelude | not $ any isPrelude res] ++ res
where
res = [x | x <- moduleImports xs, importPkg x /= Just "hint"]
prelude = ImportDecl an (ModuleName an "Prelude") False False False Nothing Nothing Nothing
isPrelude x = fromModuleName (importModule x) == "Prelude"
scopeImports :: Scope -> [ImportDecl S]
scopeImports (Scope x) = x
-- | Given a two names in scopes, could they possibly refer to the same thing.
-- This property is reflexive.
scopeMatch :: (Scope, QName S) -> (Scope, QName S) -> Bool
scopeMatch (a, x@Special{}) (b, y@Special{}) = x =~= y
scopeMatch (a, x) (b, y) | isSpecial x || isSpecial y = False
scopeMatch (a, x) (b, y) = unqual x =~= unqual y && not (null $ possModules a x `intersect` possModules b y)
-- | Given a name in a scope, and a new scope, create a name for the new scope that will refer
-- to the same thing. If the resulting name is ambiguous, it picks a plausible candidate.
scopeMove :: (Scope, QName S) -> Scope -> QName S
scopeMove (a, x@(fromQual -> Just name)) (Scope b)
| null imps = head $ real ++ [x]
| any (not . importQualified) imps = unqual x
| otherwise = Qual an (head $ mapMaybe importAs imps ++ map importModule imps) name
where
real = [Qual an (ModuleName an m) name | m <- possModules a x]
imps = [i | r <- real, i <- b, possImport i r]
scopeMove (_, x) _ = x
-- which modules could a name possibly lie in
-- if it's qualified but not matching any import, assume the user
-- just lacks an import
possModules :: Scope -> QName S -> [String]
possModules (Scope is) x = f x
where
res = [fromModuleName $ importModule i | i <- is, possImport i x]
f Special{} = [""]
f x@(Qual _ mod _) = [fromModuleName mod | null res] ++ res
f _ = res
possImport :: ImportDecl S -> QName S -> Bool
possImport i Special{} = False
possImport i (Qual _ mod x) = fromModuleName mod `elem` map fromModuleName ms && possImport i{importQualified=False} (UnQual an x)
where ms = importModule i : maybeToList (importAs i)
possImport i (UnQual _ x) = not (importQualified i) && maybe True f (importSpecs i)
where
f (ImportSpecList _ hide xs) = if hide then Just True `notElem` ms else Nothing `elem` ms || Just True `elem` ms
where ms = map g xs
g :: ImportSpec S -> Maybe Bool -- does this import cover the name x
g (IVar _ y) = Just $ x =~= y
g (IAbs _ _ y) = Just $ x =~= y
g (IThingAll _ y) = if x =~= y then Just True else Nothing
g (IThingWith _ y ys) = Just $ x `elem_` (y : map fromCName ys)
fromCName :: CName S -> Name S
fromCName (VarName _ x) = x
fromCName (ConName _ x) = x
hlint-2.0.11/src/HSE/Reduce.hs 0000644 0000000 0000000 00000001556 13210071537 014056 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns #-}
-- Evaluate/reduce a HSE Exp as much as possible
module HSE.Reduce(reduce) where
import HSE.Match
import HSE.Util
import HSE.Type
import Language.Haskell.Exts.Util
reduce :: Exp_ -> Exp_
reduce = fromParen . transform reduce1
reduce1 :: Exp_ -> Exp_
reduce1 (App s len (Lit _ (String _ xs _))) | len ~= "length" = Lit s $ Int s n (show n)
where n = fromIntegral $ length xs
reduce1 (App s len (List _ xs)) | len ~= "length" = Lit s $ Int s n (show n)
where n = fromIntegral $ length xs
reduce1 (view -> App2 op (Lit _ x) (Lit _ y)) | op ~= "==" = toNamed $ show $ x =~= y
reduce1 (view -> App2 op (Lit _ (Int _ x _)) (Lit _ (Int _ y _)))
| op ~= ">=" = toNamed $ show $ x >= y
reduce1 (view -> App2 op x y)
| op ~= "&&" && x ~= "True" = y
| op ~= "&&" && x ~= "False" = x
reduce1 (Paren _ x) | isAtom x = x
reduce1 x = x
hlint-2.0.11/src/HSE/Match.hs 0000644 0000000 0000000 00000010463 13210071537 013700 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances #-}
module HSE.Match(
View(..), Named(..),
(~=), isSym,
App2(App2), LamConst1(LamConst1), PVar_(PVar_), Var_(Var_), PApp_(PApp_)
) where
import Data.Char
import HSE.Type
import HSE.Util
class View a b where
view :: a -> b
data App2 = NoApp2 | App2 Exp_ Exp_ Exp_ deriving Show
instance View Exp_ App2 where
view (fromParen -> InfixApp _ lhs op rhs) = App2 (opExp op) lhs rhs
view (fromParen -> App _ (fromParen -> App _ f x) y) = App2 f x y
view _ = NoApp2
data App1 = NoApp1 | App1 Exp_ Exp_ deriving Show
instance View Exp_ App1 where
view (fromParen -> App _ f x) = App1 f x
view _ = NoApp1
-- \_ -> body
data LamConst1 = NoLamConst1 | LamConst1 Exp_ deriving Show
instance View Exp_ LamConst1 where
view (fromParen -> Lambda _ [PWildCard _] x) = LamConst1 x
view _ = NoLamConst1
data PApp_ = NoPApp_ | PApp_ String [Pat_]
instance View Pat_ PApp_ where
view (fromPParen -> PApp _ x xs) = PApp_ (fromNamed x) xs
view (fromPParen -> PInfixApp _ lhs op rhs) = PApp_ (fromNamed op) [lhs, rhs]
view _ = NoPApp_
data PVar_ = NoPVar_ | PVar_ String
instance View Pat_ PVar_ where
view (fromPParen -> PVar _ x) = PVar_ $ fromNamed x
view _ = NoPVar_
data Var_ = NoVar_ | Var_ String deriving Eq
instance View Exp_ Var_ where
view (fromParen -> Var _ (UnQual _ x)) = Var_ $ fromNamed x
view _ = NoVar_
(~=) :: Named a => a -> String -> Bool
(~=) = (==) . fromNamed
-- | fromNamed will return \"\" when it cannot be represented
-- toNamed may crash on \"\"
class Named a where
toNamed :: String -> a
fromNamed :: a -> String
isCtor (x:_) = isUpper x || x == ':'
isCtor _ = False
isSym (x:_) = not $ isAlpha x || x `elem` "_'"
isSym _ = False
instance Named (Exp S) where
fromNamed (Var _ x) = fromNamed x
fromNamed (Con _ x) = fromNamed x
fromNamed (List _ []) = "[]"
fromNamed _ = ""
toNamed "[]" = List an []
toNamed x | isCtor x = Con an $ toNamed x
| otherwise = Var an $ toNamed x
instance Named (QName S) where
fromNamed (Special _ Cons{}) = ":"
fromNamed (Special _ UnitCon{}) = "()"
fromNamed (UnQual _ x) = fromNamed x
fromNamed _ = ""
toNamed ":" = Special an $ Cons an
toNamed x = UnQual an $ toNamed x
instance Named (Name S) where
fromNamed (Ident _ x) = x
fromNamed (Symbol _ x) = x
toNamed x | isSym x = Symbol an x
| otherwise = Ident an x
instance Named (ModuleName S) where
fromNamed (ModuleName _ x) = x
toNamed = ModuleName an
instance Named (Pat S) where
fromNamed (PVar _ x) = fromNamed x
fromNamed (PApp _ x []) = fromNamed x
fromNamed (PList _ []) = "[]"
fromNamed _ = ""
toNamed x | isCtor x = PApp an (toNamed x) []
| otherwise = PVar an $ toNamed x
instance Named (TyVarBind S) where
fromNamed (KindedVar _ x _) = fromNamed x
fromNamed (UnkindedVar _ x) = fromNamed x
toNamed x = UnkindedVar an (toNamed x)
instance Named (QOp S) where
fromNamed (QVarOp _ x) = fromNamed x
fromNamed (QConOp _ x) = fromNamed x
toNamed x | isCtor x = QConOp an $ toNamed x
| otherwise = QVarOp an $ toNamed x
instance Named (Match S) where
fromNamed (Match _ x _ _ _) = fromNamed x
fromNamed (InfixMatch _ _ x _ _ _) = fromNamed x
toNamed = error "No toNamed for Match"
instance Named (DeclHead S) where
fromNamed (DHead _ x) = fromNamed x
fromNamed (DHInfix _ _ x) = fromNamed x
fromNamed (DHParen _ x) = fromNamed x
fromNamed (DHApp _ x _) = fromNamed x
toNamed = error "No toNamed for DeclHead"
instance Named (Decl S) where
fromNamed (TypeDecl _ name _) = fromNamed name
fromNamed (DataDecl _ _ _ name _ _) = fromNamed name
fromNamed (GDataDecl _ _ _ name _ _ _) = fromNamed name
fromNamed (TypeFamDecl _ name _ _) = fromNamed name
fromNamed (DataFamDecl _ _ name _) = fromNamed name
fromNamed (ClassDecl _ _ name _ _) = fromNamed name
fromNamed (PatBind _ (PVar _ name) _ _) = fromNamed name
fromNamed (FunBind _ (name:_)) = fromNamed name
fromNamed (ForImp _ _ _ _ name _) = fromNamed name
fromNamed (ForExp _ _ _ name _) = fromNamed name
fromNamed (TypeSig _ (name:_) _) = fromNamed name
fromNamed _ = ""
toNamed = error "No toNamed for Decl"
hlint-2.0.11/src/HSE/All.hs 0000644 0000000 0000000 00000015324 13210071537 013355 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
module HSE.All(
module X,
CppFlags(..), ParseFlags(..), defaultParseFlags,
parseFlagsAddFixities, parseFlagsSetLanguage,
parseModuleEx, ParseError(..),
freeVars, vars, varss, pvars
) where
import Language.Haskell.Exts.Util hiding (freeVars, Vars(..))
import qualified Language.Haskell.Exts.Util as X
import HSE.Util as X
import HSE.Reduce as X
import HSE.Type as X
import HSE.Match as X
import HSE.Scope as X
import Util
import Data.Char
import Data.List.Extra
import Data.Maybe
import Language.Preprocessor.Cpphs
import Data.Set (Set)
import qualified Data.Map as Map
import qualified Data.Set as Set
import System.IO.Extra
import Data.Functor
import Prelude
vars :: FreeVars a => a -> [String]
freeVars :: FreeVars a => a -> Set String
varss, pvars :: AllVars a => a -> [String]
vars = Set.toList . Set.map prettyPrint . X.freeVars
varss = Set.toList . Set.map prettyPrint . X.free . X.allVars
pvars = Set.toList . Set.map prettyPrint . X.bound . X.allVars
freeVars = Set.map prettyPrint . X.freeVars
-- | What C pre processor should be used.
data CppFlags
= NoCpp -- ^ No pre processing is done.
| CppSimple -- ^ Lines prefixed with @#@ are stripped.
| Cpphs CpphsOptions -- ^ The @cpphs@ library is used.
-- | Created with 'defaultParseFlags', used by 'parseModuleEx'.
data ParseFlags = ParseFlags
{cppFlags :: CppFlags -- ^ How the file is preprocessed (defaults to 'NoCpp').
,hseFlags :: ParseMode -- ^ How the file is parsed (defaults to all fixities in the @base@ package and most non-conflicting extensions).
}
-- | Default value for 'ParseFlags'.
defaultParseFlags :: ParseFlags
defaultParseFlags = ParseFlags NoCpp
defaultParseMode{fixities=Just baseFixities, ignoreLinePragmas=False, ignoreFunctionArity=True, extensions=defaultExtensions}
parseFlagsNoLocations :: ParseFlags -> ParseFlags
parseFlagsNoLocations x = x{cppFlags = case cppFlags x of Cpphs y -> Cpphs $ f y; y -> y}
where f x = x{boolopts = (boolopts x){locations=False}}
-- | Given some fixities, add them to the existing fixities in 'ParseFlags'.
parseFlagsAddFixities :: [Fixity] -> ParseFlags -> ParseFlags
parseFlagsAddFixities fx x = x{hseFlags=hse{fixities = Just $ fx ++ fromMaybe [] (fixities hse)}}
where hse = hseFlags x
parseFlagsSetLanguage :: (Language, [Extension]) -> ParseFlags -> ParseFlags
parseFlagsSetLanguage (l, es) x = x{hseFlags=(hseFlags x){baseLanguage = l, extensions = es}}
runCpp :: CppFlags -> FilePath -> String -> IO String
runCpp NoCpp _ x = return x
runCpp CppSimple _ x = return $ unlines [if "#" `isPrefixOf` trimStart x then "" else x | x <- lines x]
runCpp (Cpphs o) file x = dropLine <$> runCpphs o file x
where
-- LINE pragmas always inserted when locations=True
dropLine (line1 -> (a,b)) | "{-# LINE " `isPrefixOf` a = b
dropLine x = x
---------------------------------------------------------------------
-- PARSING
-- | A parse error from 'parseModuleEx'.
data ParseError = ParseError
{parseErrorLocation :: SrcLoc -- ^ Location of the error.
,parseErrorMessage :: String -- ^ Message about the cause of the error.
,parseErrorContents :: String -- ^ Snippet of several lines (typically 5) including a @>@ character pointing at the faulty line.
}
-- | Parse a Haskell module. Applies the C pre processor, and uses best-guess fixity resolution if there are ambiguities.
-- The filename @-@ is treated as @stdin@. Requires some flags (often 'defaultParseFlags'), the filename, and optionally the contents of that file.
parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError (Module SrcSpanInfo, [Comment]))
parseModuleEx flags file str = do
str <- case str of
Just x -> return x
Nothing | file == "-" -> getContents
| otherwise -> readFileUTF8' file
str <- return $ fromMaybe str $ stripPrefix "\65279" str -- remove the BOM if it exists, see #130
ppstr <- runCpp (cppFlags flags) file str
case parseFileContentsWithComments (mode flags) ppstr of
ParseOk (x, cs) -> return $ Right (applyFixity fixity x, cs)
ParseFailed sl msg -> do
-- figure out the best line number to grab context from, by reparsing
-- but not generating {-# LINE #-} pragmas
flags <- return $ parseFlagsNoLocations flags
ppstr2 <- runCpp (cppFlags flags) file str
let pe = case parseFileContentsWithMode (mode flags) ppstr2 of
ParseFailed sl2 _ -> context (srcLine sl2) ppstr2
_ -> context (srcLine sl) ppstr
return $ Left $ ParseError sl msg pe
where
fixity = fromMaybe [] $ fixities $ hseFlags flags
mode flags = (hseFlags flags)
{parseFilename = file
,fixities = Nothing
}
-- | Given a line number, and some source code, put bird ticks around the appropriate bit.
context :: Int -> String -> String
context lineNo src =
unlines $ dropWhileEnd (all isSpace) $ dropWhile (all isSpace) $
zipWith (++) ticks $ take 5 $ drop (lineNo - 3) $ lines src ++ ["","","","",""]
where ticks = [" "," ","> "," "," "]
---------------------------------------------------------------------
-- FIXITIES
-- resolve fixities later, so we don't ever get uncatchable ambiguity errors
-- if there are fixity errors, try the cheapFixities (which never fails)
applyFixity :: [Fixity] -> Module_ -> Module_
applyFixity base modu = descendBi f modu
where
f x = fromMaybe (cheapFixities fixs x) $ applyFixities fixs x :: Decl_
fixs = concatMap getFixity (moduleDecls modu) ++ base
-- Apply fixities, but ignoring any ambiguous fixity errors and skipping qualified names,
-- local infix declarations etc. Only use as a backup, if HSE gives an error.
--
-- Inspired by the code at:
-- http://hackage.haskell.org/trac/haskell-prime/attachment/wiki/FixityResolution/resolve.hs
cheapFixities :: [Fixity] -> Decl_ -> Decl_
cheapFixities fixs = descendBi (transform f)
where
ask = askFixity fixs
f o@(InfixApp s1 (InfixApp s2 x op1 y) op2 z)
| p1 == p2 && (a1 /= a2 || isAssocNone a1) = o -- Ambiguous infix expression!
| p1 > p2 || p1 == p2 && (isAssocLeft a1 || isAssocNone a2) = o
| otherwise = InfixApp s1 x op1 (f $ InfixApp s1 y op2 z)
where
(a1,p1) = ask op1
(a2,p2) = ask op2
f x = x
askFixity :: [Fixity] -> QOp S -> (Assoc (), Int)
askFixity xs = \k -> Map.findWithDefault (AssocLeft (), 9) (fromNamed k) mp
where
mp = Map.fromList [(s,(a,p)) | Fixity a p x <- xs, let s = fromNamed $ fmap (const an) x, s /= ""]
hlint-2.0.11/src/Hint/ 0000755 0000000 0000000 00000000000 13210071537 012567 5 ustar 00 0000000 0000000 hlint-2.0.11/src/Hint/Util.hs 0000644 0000000 0000000 00000010504 13210071537 014040 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, ViewPatterns #-}
module Hint.Util(niceLambda, simplifyExp, niceLambdaR) where
import HSE.All
import Data.List.Extra
import Refact.Types
import Refact
import qualified Refact.Types as R (SrcSpan)
niceLambda :: [String] -> Exp_ -> Exp_
niceLambda ss e = fst (niceLambdaR ss e)
-- | Generate a lambda, but prettier (if possible).
-- Generally no lambda is good, but removing just some arguments isn't so useful.
niceLambdaR :: [String] -> Exp_ -> (Exp_, R.SrcSpan -> [Refactoring R.SrcSpan])
-- \xs -> (e) ==> \xs -> e
niceLambdaR xs (Paren l x) = niceLambdaR xs x
-- \xs -> \v vs -> e ==> \xs v -> \vs -> e
-- \xs -> \ -> e ==> \xs -> e
niceLambdaR xs (Lambda _ ((view -> PVar_ v):vs) x) | v `notElem` xs = niceLambdaR (xs++[v]) (Lambda an vs x)
niceLambdaR xs (Lambda _ [] x) = niceLambdaR xs x
-- \ -> e ==> e
niceLambdaR [] x = (x, const [])
-- \vs v -> e $ v ==> \vs -> e
niceLambdaR (unsnoc -> Just (vs, v)) (InfixApp _ e (isDol -> True) (view -> Var_ v2))
| v == v2, vars e `disjoint` [v]
= niceLambdaR vs e
-- \xs -> e xs ==> e
niceLambdaR xs (fromAppsWithLoc -> e) | map view xs2 == map Var_ xs, vars e2 `disjoint` xs, not $ null e2 =
(apps e2, \s -> [Replace Expr s [("x", pos)] "x"])
where (e',xs') = splitAt (length e - length xs) e
(e2, xs2) = (map fst e', map fst xs')
pos = toRefactSrcSpan . srcInfoSpan $ snd (last e')
-- \x y -> x + y ==> (+)
niceLambdaR [x,y] (InfixApp _ (view -> Var_ x1) (opExp -> op) (view -> Var_ y1))
| x == x1, y == y1, vars op `disjoint` [x,y] = (op, \s -> [Replace Expr s [] (prettyPrint op)])
-- \x -> x + b ==> (+ b) [heuristic, b must be a single lexeme, or gets too complex]
niceLambdaR [x] (view -> App2 (expOp -> Just op) a b)
| isLexeme b, view a == Var_ x, x `notElem` vars b, allowRightSection (fromNamed op) =
let e = rebracket1 $ RightSection an op b
in (e, \s -> [Replace Expr s [] (prettyPrint e)])
-- \x y -> f y x = flip f
niceLambdaR [x,y] (view -> App2 op (view -> Var_ y1) (view -> Var_ x1))
| x == x1, y == y1, vars op `disjoint` [x,y] = (gen op, \s -> [Replace Expr s [("x", toSS op)] (prettyPrint $ gen (toNamed "x"))])
where
gen = App an (toNamed "flip")
-- \x -> f (b x) ==> f . b
-- \x -> f $ b x ==> f . b
niceLambdaR [x] y | Just (z, subts) <- factor y, x `notElem` vars z = (z, \s -> [mkRefact subts s])
where
-- factor the expression with respect to x
factor y@(App _ ini lst) | view lst == Var_ x = Just (ini, [ann ini])
factor y@(App _ ini lst) | Just (z, ss) <- factor lst = let r = niceDotApp ini z
in if r == z then Just (r, ss)
else Just (r, ann ini : ss)
factor (InfixApp _ y op (factor -> Just (z, ss))) | isDol op = let r = niceDotApp y z
in if r == z then Just (r, ss)
else Just (r, ann y : ss)
factor (Paren _ y@App{}) = factor y
factor _ = Nothing
mkRefact :: [S] -> R.SrcSpan -> Refactoring R.SrcSpan
mkRefact subts s =
let tempSubts = zipWith (\a b -> ([a], toRefactSrcSpan $ srcInfoSpan b)) ['a' .. 'z'] subts
template = dotApps (map (toNamed . fst) tempSubts)
in Replace Expr s tempSubts (prettyPrint template)
-- \x -> (x +) ==> (+)
-- Section handling is not yet supported for refactoring
niceLambdaR [x] (LeftSection _ (view -> Var_ x1) op) | x == x1 =
let e = opExp op
in (e, \s -> [Replace Expr s [] (prettyPrint e)])
-- base case
niceLambdaR ps x = (Lambda an (map toNamed ps) x, const [])
-- ($) . b ==> b
niceDotApp :: Exp_ -> Exp_ -> Exp_
niceDotApp a b | a ~= "$" = b
| otherwise = dotApp a b
-- | Convert expressions which have redundant junk in them away.
-- Mainly so that later stages can match on fewer alternatives.
simplifyExp :: Exp_ -> Exp_
simplifyExp (InfixApp _ x dol y) | isDol dol = App an x (paren y)
simplifyExp (Let _ (BDecls _ [PatBind _ (view -> PVar_ x) (UnGuardedRhs _ y) Nothing]) z)
| x `notElem` vars y && length [() | UnQual _ a <- universeS z, prettyPrint a == x] <= 1 = transform f z
where f (view -> Var_ x') | x == x' = paren y
f x = x
simplifyExp x = x
hlint-2.0.11/src/Hint/Unsafe.hs 0000644 0000000 0000000 00000003745 13210071537 014355 0 ustar 00 0000000 0000000
{-
Find things that are unsafe
{-# 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
-}
module Hint.Unsafe(unsafeHint) where
import Hint.Type
import Data.Char
import Refact.Types
unsafeHint :: ModuHint
unsafeHint _ m =
[ rawIdea Warning "Missing NOINLINE pragma" (srcInfoSpan $ ann d)
(prettyPrint d)
(Just $ dropWhile isSpace (prettyPrint $ gen x) ++ "\n" ++ prettyPrint d)
[] [InsertComment (toSS d) (prettyPrint $ gen x)]
| d@(PatBind _ (PVar _ x) _ _) <- moduleDecls m
, isUnsafeDecl d, x `notElem_` noinline]
where
gen x = InlineSig an False Nothing $ UnQual an x
noinline = [q | InlineSig _ False Nothing (UnQual _ q) <- moduleDecls m]
isUnsafeDecl :: Decl_ -> Bool
isUnsafeDecl (PatBind _ _ rhs bind) =
any isUnsafeApp (childrenBi rhs) || any isUnsafeDecl (childrenBi bind)
isUnsafeDecl _ = False
-- Am I equivalent to @unsafePerformIO x@
isUnsafeApp :: Exp_ -> Bool
isUnsafeApp (InfixApp _ x d _) | isDol d = isUnsafeFun x
isUnsafeApp (App _ x _) = isUnsafeFun x
isUnsafeApp _ = False
-- Am I equivalent to @unsafePerformIO . x@
isUnsafeFun :: Exp_ -> Bool
isUnsafeFun (Var _ x) | x ~= "unsafePerformIO" = True
isUnsafeFun (InfixApp _ x d _) | isDot d = isUnsafeFun x
isUnsafeFun _ = False
hlint-2.0.11/src/Hint/Type.hs 0000644 0000000 0000000 00000002715 13210071537 014051 0 ustar 00 0000000 0000000
module Hint.Type(
DeclHint, ModuHint, CrossHint, Hint(..),
module Export
) where
import Data.Monoid
import Config.Type
import HSE.All as Export
import Idea as Export
import Prelude
import Refact as Export
type DeclHint = Scope -> Module_ -> Decl_ -> [Idea]
type ModuHint = Scope -> Module_ -> [Idea]
type CrossHint = [(Scope, Module_)] -> [Idea]
-- | Functions to generate hints, combined using the 'Monoid' instance.
data Hint {- PUBLIC -} = Hint
{hintModules :: [Setting] -> [(Scope, Module SrcSpanInfo)] -> [Idea] -- ^ Given a list of modules (and their scope information) generate some 'Idea's.
,hintModule :: [Setting] -> Scope -> Module SrcSpanInfo -> [Idea] -- ^ Given a single module and its scope information generate some 'Idea's.
,hintDecl :: [Setting] -> Scope -> Module SrcSpanInfo -> Decl SrcSpanInfo -> [Idea]
-- ^ Given a declaration (with a module and scope) generate some 'Idea's.
-- This function will be partially applied with one module/scope, then used on multiple 'Decl' values.
,hintComment :: [Setting] -> Comment -> [Idea] -- ^ Given a comment generate some 'Idea's.
}
instance Monoid Hint where
mempty = Hint (\_ _ -> []) (\_ _ _ -> []) (\_ _ _ _ -> []) (\_ _ -> [])
mappend (Hint x1 x2 x3 x4) (Hint y1 y2 y3 y4) = Hint
(\a b -> x1 a b ++ y1 a b)
(\a b c -> x2 a b c ++ y2 a b c)
(\a b c d -> x3 a b c d ++ y3 a b c d)
(\a b -> x4 a b ++ y4 a b)
hlint-2.0.11/src/Hint/Restrict.hs 0000644 0000000 0000000 00000007502 13210071537 014726 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards #-}
module Hint.Restrict(restrictHint) where
{-
-- These tests rely on the .hlint.yaml file in the root
foo = unsafePerformIO --
module Util where otherFunc = unsafePerformIO $ print 1 --
module Util where exitMessageImpure = unsafePerformIO $ print 1
foo = unsafePerformOI
-}
import qualified Data.Map as Map
import Config.Type
import Hint.Type
import Data.List
import Data.Maybe
import Data.Monoid
import Control.Applicative
import Prelude
-- FIXME: The settings should be partially applied, but that's hard to orchestrate right now
restrictHint :: [Setting] -> ModuHint
restrictHint settings scope m =
checkPragmas modu (modulePragmas m) restrict ++
maybe [] (checkImports modu $ moduleImports m) (Map.lookup RestrictModule restrict) ++
maybe [] (checkFunctions modu $ moduleDecls m) (Map.lookup RestrictFunction restrict)
where
modu = moduleName m
restrict = restrictions settings
---------------------------------------------------------------------
-- UTILITIES
data RestrictItem = RestrictItem
{riAs :: [String]
,riWithin :: [(String, String)]
}
instance Monoid RestrictItem where
mempty = RestrictItem [] []
mappend (RestrictItem x1 x2) (RestrictItem y1 y2) = RestrictItem (x1<>y1) (x2<>y2)
restrictions :: [Setting] -> Map.Map RestrictType (Bool, Map.Map String RestrictItem)
restrictions settings = Map.map f $ Map.fromListWith (++) [(restrictType x, [x]) | SettingRestrict x <- settings]
where
f rs = (all restrictDefault rs
,Map.fromListWith (<>) [(s, RestrictItem restrictAs restrictWithin) | Restrict{..} <- rs, s <- restrictName])
ideaMayBreak w = w{ideaNote=[Note "may break the code"]}
ideaNoTo w = w{ideaTo=Nothing}
within :: String -> String -> RestrictItem -> Bool
within modu func RestrictItem{..} = any (\(a,b) -> (a == modu || a == "") && (b == func || b == "")) riWithin
---------------------------------------------------------------------
-- CHECKS
checkPragmas :: String -> [ModulePragma S] -> Map.Map RestrictType (Bool, Map.Map String RestrictItem) -> [Idea]
checkPragmas modu xs mps = f RestrictFlag "flags" onFlags ++ f RestrictExtension "extensions" onExtensions
where
f tag name sel =
[ (if null good then ideaNoTo else id) $ ideaMayBreak $ warn ("Avoid restricted " ++ name) o (regen good) []
| Just mp <- [Map.lookup tag mps]
, o <- xs, Just (xs, regen) <- [sel o]
, let (good, bad) = partition (isGood mp) xs, not $ null bad]
onFlags (OptionsPragma s t x) = Just (words x, OptionsPragma s t . unwords)
onFlags _ = Nothing
onExtensions (LanguagePragma s xs) = Just (map fromNamed xs, LanguagePragma (s :: S) . map toNamed)
onExtensions _ = Nothing
isGood (def, mp) x = maybe def (within modu "") $ Map.lookup x mp
checkImports :: String -> [ImportDecl S] -> (Bool, Map.Map String RestrictItem) -> [Idea]
checkImports modu imp (def, mp) =
[ ideaMayBreak $ if not allowImport
then ideaNoTo $ warn "Avoid restricted module" i i []
else warn "Avoid restricted qualification" i i{importAs=ModuleName an <$> listToMaybe riAs} []
| i@ImportDecl{..} <- imp
, let ri@RestrictItem{..} = Map.findWithDefault (RestrictItem [] [("","") | def]) (fromModuleName importModule) mp
, let allowImport = within modu "" ri
, let allowQual = maybe True (\x -> null riAs || fromModuleName x `elem` riAs) importAs
, not allowImport || not allowQual
]
checkFunctions :: String -> [Decl_] -> (Bool, Map.Map String RestrictItem) -> [Idea]
checkFunctions modu decls (def, mp) =
[ ideaMayBreak $ ideaNoTo $ warn "Avoid restricted function" x x []
| d <- decls
, let dname = fromNamed d
, x@Var{} <- universeBi d
, not $ maybe def (within modu dname) $ Map.lookup (fromNamed x) mp
]
hlint-2.0.11/src/Hint/Pragma.hs 0000644 0000000 0000000 00000010061 13210071537 014330 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-
Suggest better pragmas
OPTIONS_GHC -cpp => LANGUAGE CPP
OPTIONS_GHC -fglasgow-exts => LANGUAGE ... (in HSE)
OPTIONS_GHC -XFoo => LANGUAGE Foo
LANGUAGE A, A => LANGUAGE A
-- do not do LANGUAGE A, LANGUAGE B to combine
{-# OPTIONS_GHC -cpp #-} -- {-# LANGUAGE CPP #-}
{-# OPTIONS -cpp #-} -- {-# LANGUAGE CPP #-}
{-# OPTIONS_YHC -cpp #-}
{-# OPTIONS_GHC -XFoo #-} -- {-# LANGUAGE Foo #-}
{-# OPTIONS_GHC -fglasgow-exts #-} -- ???
{-# LANGUAGE A, B, C, A #-} -- {-# LANGUAGE A, B, C #-}
{-# LANGUAGE A #-}
{-# OPTIONS_GHC -cpp -foo #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -foo #-}
{-# OPTIONS_GHC -cpp #-} \
{-# LANGUAGE CPP, Text #-} --
{-# LANGUAGE A #-} \
{-# LANGUAGE B #-}
{-# LANGUAGE A #-} \
{-# LANGUAGE B, A #-} -- {-# LANGUAGE A, B #-}
-}
module Hint.Pragma(pragmaHint) where
import Hint.Type
import Data.List
import Data.Maybe
import Refact.Types
import qualified Refact.Types as R
pragmaHint :: ModuHint
pragmaHint _ x = languageDupes lang ++ optToPragma x lang
where
lang = [x | x@LanguagePragma{} <- modulePragmas x]
optToPragma :: Module_ -> [ModulePragma S] -> [Idea]
optToPragma x lang =
[pragmaIdea (OptionsToComment old ys rs) | old /= []]
where
(old,new,ns, rs) =
unzip4 [(old,new,ns, r)
| old <- modulePragmas x, Just (new,ns) <- [optToLanguage old ls]
, let r = mkRefact old new ns]
ls = concat [map fromNamed n | LanguagePragma _ n <- lang]
ns2 = nub (concat ns) \\ ls
ys = [LanguagePragma an (map toNamed ns2) | ns2 /= []] ++ catMaybes new
mkRefact :: ModulePragma S -> Maybe (ModulePragma S) -> [String] -> Refactoring R.SrcSpan
mkRefact old (maybe "" prettyPrint -> new) ns =
let ns' = map (\n -> prettyPrint $ LanguagePragma an [toNamed n]) ns
in
ModifyComment (toSS old) (intercalate "\n" (filter (not . null) (new: ns')))
data PragmaIdea = SingleComment (ModulePragma S) (ModulePragma S)
| MultiComment (ModulePragma S) (ModulePragma S) (ModulePragma S)
| OptionsToComment [ModulePragma S] [ModulePragma S] [Refactoring R.SrcSpan]
pragmaIdea :: PragmaIdea -> Idea
pragmaIdea pidea =
case pidea of
SingleComment old new ->
mkIdea (srcInfoSpan . ann $ old)
(prettyPrint old) (Just $ prettyPrint new) []
[ModifyComment (toSS old) (prettyPrint new)]
MultiComment repl delete new ->
mkIdea (srcInfoSpan . ann $ repl)
(f [repl, delete]) (Just $ prettyPrint new) []
[ ModifyComment (toSS repl) (prettyPrint new)
, ModifyComment (toSS delete) ""]
OptionsToComment old new r ->
mkIdea (srcInfoSpan . ann . head $ old)
(f old) (Just $ f new) []
r
where
f = unlines . map prettyPrint
mkIdea = rawIdea Warning "Use better pragmas"
languageDupes :: [ModulePragma S] -> [Idea]
languageDupes (a@(LanguagePragma _ x):xs) =
(if nub_ x `neqList` x
then [pragmaIdea (SingleComment a (LanguagePragma (ann a) $ nub_ x))]
else [pragmaIdea (MultiComment a b (LanguagePragma (ann a) (nub_ $ x ++ y))) | b@(LanguagePragma _ y) <- xs, not $ null $ intersect_ x y]) ++
languageDupes xs
languageDupes _ = []
-- Given a pragma, can you extract some language features out
strToLanguage :: String -> Maybe [String]
strToLanguage "-cpp" = Just ["CPP"]
strToLanguage x | "-X" `isPrefixOf` x = Just [drop 2 x]
strToLanguage "-fglasgow-exts" = Just $ map prettyExtension glasgowExts
strToLanguage _ = Nothing
optToLanguage :: ModulePragma S -> [String] -> Maybe (Maybe (ModulePragma S), [String])
optToLanguage (OptionsPragma sl tool val) ls
| maybe True (== GHC) tool && any isJust vs =
Just (res, filter (not . (`elem` ls)) (concat $ catMaybes vs))
where
strs = words val
vs = map strToLanguage strs
keep = concat $ zipWith (\v s -> [s | isNothing v]) vs strs
res = if null keep then Nothing else Just $ OptionsPragma sl tool (unwords keep)
optToLanguage _ _ = Nothing
hlint-2.0.11/src/Hint/Pattern.hs 0000644 0000000 0000000 00000020360 13210071537 014541 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns, PatternGuards #-}
{-
Improve the structure of code
yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e
x `yes` y = if a then b else if c then d else e -- x `yes` y ; | a = b ; | c = d ; | otherwise = e
no x y = if a then b else c
-- foo b | c <- f b = c -- foo (f -> c) = c
-- foo x y b z | c:cs <- f g b = c -- foo x y (f g -> c:cs) z = c
foo b | c <- f b = c + b
foo b | c <- f b = c where f = here
foo b | c <- f b = c where foo = b
foo b | c <- f b = c \
| 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 -- foo x = x + x
foo x | a = b | True = d -- foo x | a = b ; | otherwise = d
foo (Bar _ _ _ _) = x -- Bar{}
foo (Bar _ x _ _) = x
foo (Bar _ _) = x
foo = case f v of _ -> x -- x
foo = case v of v -> x -- x
foo = case v of z -> z
foo = case v of _ | False -> x
foo = case v of !True -> x -- True
foo = case v of !(Just x) -> x -- (Just x)
foo = case v of !(x : xs) -> x -- (x:xs)
foo = case v of !1 -> x -- 1
foo = case v of !x -> x
foo = case v of !(I# x) -> y -- (I# x)
foo = let ~x = 1 in y -- x
foo = let ~(x:xs) = y in z
foo = let !x = undefined in y
foo = let !(I# x) = 4 in x
foo = let !(Just x) = Nothing in 3
foo = 1 where f !False = 2 -- False
foo = 1 where !False = True
foo = 1 where g (Just !True) = Nothing -- True
foo = 1 where Just !True = Nothing
foo otherwise = 1 -- _
foo ~x = y -- x
{-# LANGUAGE Strict #-} foo ~x = y
foo !(x, y) = x -- (x, y)
foo ![x] = x -- [x]
foo !Bar { bar = x } = x -- Bar { bar = x }
l !(() :: ()) = x -- (() :: ())
-}
module Hint.Pattern(patternHint) where
import Hint.Type
import Data.Function
import Data.List.Extra
import Data.Tuple
import Data.Maybe
import Data.Either
import Refact.Types hiding (RType(Pattern, Match))
import qualified Refact.Types as R (RType(Pattern, Match), SrcSpan)
patternHint :: DeclHint
patternHint _ modu x =
concatMap (uncurry hints . swap) (asPattern x) ++
-- PatBind (used in Let and Where) contains lazy-by-default patterns, everything else is strict
concatMap (patHint strict False) (universeBi [p | PatBind _ p _ _ <- universe x]) ++
concatMap (patHint strict True) (universeBi $ transform noPatBind x) ++
concatMap expHint (universeBi x)
where
noPatBind (PatBind a _ b c) = PatBind a (PWildCard a) b c
noPatBind x = x
strict = "Strict" `elem` [n | LanguagePragma _ ns <- modulePragmas modu, Ident _ n <- ns]
hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea]
hints gen (Pattern l rtype pat (UnGuardedRhs d bod) bind)
| length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GuardedRhss d guards) bind) [refactoring]]
where rawGuards = asGuards bod
mkGuard a = GuardedRhs an [Qualifier an a]
guards = map (uncurry mkGuard) rawGuards
(lhs, rhs) = unzip rawGuards
mkTemplate c ps =
-- Check if the expression has been injected or is natural
let checkAn p v = if ann p == an then Left p else Right ( c ++ [v], toSS p)
in zipWith checkAn ps ['1' .. '9']
patSubts = case pat of
[p] -> [Left p] -- Substitution doesn't work properly for PatBinds
-- This will probably produce
-- unexpected results if the pattern
-- contains any template variables
ps -> mkTemplate "p100" ps
guardSubts = mkTemplate "g100" lhs
exprSubts = mkTemplate "e100" rhs
templateGuards = zipWith (mkGuard `on` toString) guardSubts exprSubts
toString (Left e) = e
toString (Right (v, _)) = toNamed v
template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString patSubts) (GuardedRhss d templateGuards) bind) [])
f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)]
f = rights
refactoring = Replace rtype (toRefactSrcSpan $ srcInfoSpan l) (f patSubts ++ f guardSubts ++ f exprSubts) template
{-
-- Do not suggest view patterns, they aren't something everyone likes sufficiently
hints gen (Pattern pats (GuardedRhss _ [GuardedRhs _ [Generator _ pat (App _ op (view -> Var_ p))] bod]) bind)
| Just i <- findIndex (=~= (toNamed p :: Pat_)) pats
, p `notElem` (vars bod ++ vars bind)
, vars op `disjoint` decsBind, pvars pats `disjoint` vars op, pvars pat `disjoint` pvars pats
= [gen "Use view patterns" $
Pattern (take i pats ++ [PParen an $ PViewPat an op pat] ++ drop (i+1) pats) (UnGuardedRhs an bod) bind]
where
decsBind = nub $ concatMap declBind $ childrenBi bind
-}
hints gen (Pattern l t pats (GuardedRhss _ [GuardedRhs _ [test] bod]) bind)
| prettyPrint test `elem` ["otherwise","True"]
= [gen "Redundant guard" (Pattern l t pats (UnGuardedRhs an bod) bind) [Delete Stmt (toSS test)]]
hints gen (Pattern l t pats bod (Just bind)) | f bind
= [gen "Redundant where" (Pattern l t pats bod Nothing) []]
where
f (BDecls _ x) = null x
f (IPBinds _ x) = null x
hints gen (Pattern l t pats (GuardedRhss _ (unsnoc -> Just (gs, GuardedRhs _ [test] bod))) bind)
| prettyPrint test == "True"
= [gen "Use otherwise" (Pattern l t pats (GuardedRhss an $ gs ++ [GuardedRhs an [Qualifier an $ toNamed "otherwise"] bod]) bind) [Replace Expr (toSS test) [] "otherwise"]]
hints _ _ = []
asGuards :: Exp_ -> [(Exp S, Exp S)]
asGuards (Paren _ x) = asGuards x
asGuards (If _ a b c) = (a, b) : asGuards c
asGuards x = [(toNamed "otherwise", x)]
data Pattern = Pattern S R.RType [Pat_] (Rhs S) (Maybe (Binds S))
-- Invariant: Number of patterns may not change
asPattern :: Decl_ -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]
asPattern x = concatMap decl (universeBi x) ++ concatMap alt (universeBi x)
where
decl o@(PatBind a pat rhs bind) = [(Pattern a Bind [pat] rhs bind, \msg (Pattern _ _ [pat] rhs bind) rs -> suggest msg o (PatBind a pat rhs bind) rs)]
decl (FunBind _ xs) = map match xs
decl _ = []
match o@(Match a b pat rhs bind) = (Pattern a R.Match pat rhs bind, \msg (Pattern _ _ pat rhs bind) rs -> suggest msg o (Match a b pat rhs bind) rs)
match o@(InfixMatch a p b ps rhs bind) = (Pattern a R.Match (p:ps) rhs bind, \msg (Pattern _ _ (p:ps) rhs bind) rs -> suggest msg o (InfixMatch a p b ps rhs bind) rs)
alt o@(Alt a pat rhs bind) = [(Pattern a R.Match [pat] rhs bind, \msg (Pattern _ _ [pat] rhs bind) rs -> suggest msg o (Alt a pat rhs bind) [])]
-- First Bool is if Strict is a language extension
-- Second Bool is if this pattern in this context is going to be evaluated strictly
patHint :: Bool -> Bool -> Pat_ -> [Idea]
patHint lang strict o@(PApp _ name args) | length args >= 3 && all isPWildCard args =
[suggest "Use record patterns" o (PRec an name []) [Replace R.Pattern (toSS o) [] (prettyPrint $ PRec an name [])] ]
patHint lang strict o@(PVar _ v) | prettyPrint v == "otherwise" = [warn "Used otherwise as a pattern" o (PWildCard an) []]
patHint lang strict o@(PBangPat _ x) | strict, f x = [warn "Redundant bang pattern" o x [r]]
where f (PParen _ x) = f x
f (PAsPat _ _ x) = f x
f PLit{} = True
f PApp{} = True
f PInfixApp{} = True
f PTuple{} = True
f PList{} = True
f PRec{} = True
f (PatTypeSig _ x _) = f x
f _ = False
r = Replace R.Pattern (toSS o) [("x", toSS x)] "x"
patHint False strict o@(PIrrPat _ x) | f x = [warn "Redundant irrefutable pattern" o x [r]]
where f (PParen _ x) = f x
f (PAsPat _ _ x) = f x
f PWildCard{} = True
f PVar{} = True
f _ = False
r = Replace R.Pattern (toSS o) [("x", toSS x)] "x"
patHint _ _ _ = []
expHint :: Exp_ -> [Idea]
expHint o@(Case _ _ [Alt _ PWildCard{} (UnGuardedRhs _ e) Nothing]) =
[suggest "Redundant case" o e [r]]
where
r = Replace Expr (toSS o) [("x", toSS e)] "x"
expHint o@(Case _ (Var _ x) [Alt _ (PVar _ y) (UnGuardedRhs _ e) Nothing])
| x =~= UnQual an y =
[suggest "Redundant case" o e [r]]
where
r = Replace Expr (toSS o) [("x", toSS e)] "x"
expHint _ = []
hlint-2.0.11/src/Hint/NewType.hs 0000644 0000000 0000000 00000003250 13210071537 014516 0 ustar 00 0000000 0000000 {-
Suggest newtype instead of data for type declarations that have
only one field. Don't suggest newtype for existentially
quantified data types because it is not valid.
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
data Color a = Red a | Green a | Blue a
data Pair a b = Pair a b
data Foo = Bar
data X = Y {-# UNPACK #-} !Int -- newtype X = Y Int
data A = A {b :: !C} -- newtype A = A {b :: C}
data A = A Int#
data A = A () -- newtype A = A ()
-}
module Hint.NewType (newtypeHint) where
import Hint.Type
newtypeHint :: DeclHint
newtypeHint _ _ = newtypeHintDecl
newtypeHintDecl :: Decl_ -> [Idea]
newtypeHintDecl x
| Just (DataType s, t, f) <- singleSimpleField x
= [(suggestN "Use newtype instead of data" x $ f (NewType s) $ fromTyBang t)
{ideaNote = [DecreasesLaziness | not $ isTyBang t]}]
newtypeHintDecl _ = []
singleSimpleField :: Decl_ -> Maybe (DataOrNew S, Type_, DataOrNew S -> Type_ -> Decl_)
singleSimpleField (DataDecl x1 dt x2 x3 [QualConDecl y1 Nothing y2 ctor] x4)
| Just (t, ft) <- f ctor = Just (dt, t, \dt t -> DataDecl x1 dt x2 x3 [QualConDecl y1 Nothing y2 $ ft t] x4)
where
f (ConDecl x1 x2 [t]) | not $ isKindHash t = Just (t, \t -> ConDecl x1 x2 [t])
f (RecDecl x1 x2 [FieldDecl y1 [y2] t]) = Just (t, \t -> RecDecl x1 x2 [FieldDecl y1 [y2] t])
f _ = Nothing
singleSimpleField _ = Nothing
hlint-2.0.11/src/Hint/Naming.hs 0000644 0000000 0000000 00000006312 13210071537 014336 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-
Suggest the use of camelCase
Only permit:
_*[A-Za-z]*_*#*'*
Apply this to things that would get exported by default only
Also allow prop_ as it's a standard QuickCheck idiom
Also allow case_ as it's a standard test-framework-th idiom
Also allow test_ as it's a standard tasty-th idiom
Also allow numbers separated by _
Also don't suggest anything mentioned elsewhere in the module
data Yes = Foo | Bar'Test -- data Yes = Foo | BarTest
data Yes = Bar | Test_Bar -- data Yes = Bar | TestBar
data No = a :::: b
data Yes = Foo {bar_cap :: Int} -- data Yes = Foo{barCap :: Int}
data No = FOO | BarBAR | BarBBar
yes_foo = yes_foo + yes_foo -- yesFoo = ...
no = 1 where yes_foo = 2
a -== b = 1
myTest = 1; my_test = 1
semiring'laws = 1 -- semiringLaws = ...
data Yes = FOO_A | Foo_B -- data Yes = FOO_A | FooB
case_foo = 1
test_foo = 1
cast_foo = 1 -- castFoo = ...
replicateM_ = 1
_foo__ = 1
section_1_1 = 1
runMutator# = 1
-}
module Hint.Naming(namingHint) where
import Hint.Type
import Data.List
import Data.Data
import Data.Char
import Data.Maybe
import qualified Data.Set as Set
namingHint :: DeclHint
namingHint _ modu = naming $ Set.fromList [x | Ident _ x <- universeS modu]
naming :: Set.Set String -> Decl_ -> [Idea]
naming seen x = [suggestN "Use camelCase" x2 (replaceNames res x2) | not $ null res]
where res = [(n,y) | n <- nub $ getNames x, Just y <- [suggestName n], not $ y `Set.member` seen]
x2 = shorten x
shorten :: Decl_ -> Decl_
shorten x = case x of
FunBind sl (Match a b c d _:_) -> FunBind sl [f (Match a b c) d]
PatBind a b c _ -> f (PatBind a b) c
x -> x
where
dots = Var an ellipses
f cont (UnGuardedRhs _ _) = cont (UnGuardedRhs an dots) Nothing
f cont (GuardedRhss _ _) = cont (GuardedRhss an [GuardedRhs an [Qualifier an dots] dots]) Nothing
getNames :: Decl_ -> [String]
getNames x = case x of
FunBind{} -> name
PatBind{} -> name
TypeDecl{} -> name
DataDecl _ _ _ _ cons _ -> name ++ [fromNamed x | QualConDecl _ _ _ x <- cons, x <- f x]
GDataDecl _ _ _ _ _ cons _ -> name ++ [fromNamed x | GadtDecl _ x _ _ <- cons]
TypeFamDecl{} -> name
DataFamDecl{} -> name
ClassDecl{} -> name
_ -> []
where
name = [fromNamed x]
f (ConDecl _ x _) = [x]
f (InfixConDecl _ _ x _) = [x]
f (RecDecl _ x ys) = x : concat [y | FieldDecl _ y _ <- ys]
suggestName :: String -> Maybe String
suggestName x
| isSym x || good || not (any isLower x) || any isDigit x ||
any (`isPrefixOf` x) ["prop_","case_","test_"] = Nothing
| otherwise = Just $ f x
where
good = all isAlphaNum $ drp '_' $ drp '#' $ drp '\'' $ reverse $ drp '_' x
drp x = dropWhile (== x)
f xs = us ++ g ys
where (us,ys) = span (== '_') xs
g x | x `elem` ["_","'","_'"] = x
g (a:x:xs) | a `elem` "_'" && isAlphaNum x = toUpper x : g xs
g (x:xs) | isAlphaNum x = x : g xs
| otherwise = g xs
g [] = []
replaceNames :: Data a => [(String,String)] -> a -> a
replaceNames rep = descendBi f
where f (Ident _ x) = Ident an $ fromMaybe x $ lookup x rep
f x = x
hlint-2.0.11/src/Hint/Monad.hs 0000644 0000000 0000000 00000013341 13210071537 014163 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-}
{-
Find and match:
mapM, foldM, forM, replicateM, sequence, zipWithM
not at the last line of a do statement, or to the left of >>
Use let x = y instead of x <- return y, unless x is contained
within y, or bound more than once in that do block.
yes = do mapM print a; return b -- mapM_ print a
yes = do _ <- mapM print a; return b -- mapM_ print a
no = mapM print a
no = do foo ; mapM print a
yes = do (bar+foo) -- (bar+foo)
no = do bar ; foo
yes = do bar; a <- foo; return a -- do bar; foo
no = do bar; a <- foo; return b
yes = do x <- bar; x -- do join bar
no = do x <- bar; x; x
{-# LANGUAGE RecursiveDo #-}; no = mdo hook <- mkTrigger pat (act >> rmHook hook) ; return hook
yes = do x <- return y; foo x -- @Suggestion do let x = y; foo x
yes = do x <- return $ y + z; foo x -- do let x = y + z; foo x
no = do x <- return x; foo x
no = do x <- return y; x <- return y; foo x
yes = do forM files $ \x -> return (); return () -- forM_ files $ \x -> return ()
yes = do if a then forM x y else sequence z q; return () -- if a then forM_ x y else sequence_ z q
yes = do case a of {_ -> forM x y; x:xs -> forM x xs}; return () -- case a of _ -> forM_ x y ; x:xs -> forM_ x xs
foldM_ f a xs = foldM f a xs >> return ()
folder f a xs = foldM f a xs >> return () -- foldM_ f a xs
folder f a xs = foldM f a xs >>= \_ -> return () -- foldM_ f a xs
yes = mapM async ds >>= mapM wait >> return () -- mapM async ds >>= mapM_ wait
main = "wait" ~> do f a $ sleep 10
main = f $ do g a $ sleep 10 -- g a $ sleep 10
main = do f a $ sleep 10 -- f a $ sleep 10
-}
module Hint.Monad(monadHint) where
import Control.Applicative
import Data.Tuple.Extra
import Data.Maybe
import Data.List
import Hint.Type
import Refact.Types
import qualified Refact.Types as R
import Prelude
badFuncs = ["mapM","foldM","forM","replicateM","sequence","zipWithM"]
monadHint :: DeclHint
monadHint _ _ d = concatMap (monadExp d) $ universeParentExp d
monadExp :: Decl_ -> (Maybe (Int, Exp_), Exp_) -> [Idea]
monadExp decl (parent, x) = case x of
(view -> App2 op x1 x2) | op ~= ">>" -> f x1
(view -> App2 op x1 (view -> LamConst1 _)) | op ~= ">>=" -> f x1
Do _ xs -> [warn "Redundant return" x (Do an y) rs | Just (y, rs) <- [monadReturn xs]] ++
[warn "Use join" x (Do an y) rs | Just (y, rs) <- [monadJoin xs ['a'..'z']]] ++
[warn "Redundant do" x y [Replace Expr (toSS x) [("y", toSS y)] "y"]
| [Qualifier _ y] <- [xs], not $ doOperator parent y] ++
[suggest "Use let" x (Do an y) rs | Just (y, rs) <- [monadLet xs]] ++
concat [f x | Qualifier _ x <- init xs] ++
concat [f x | Generator _ (PWildCard _) x <- init xs]
_ -> []
where
f x = [warn ("Use " ++ name) x y r | Just (name,y, r) <- [monadCall x], fromNamed decl /= name]
-- Sometimes people write a * do a + b, to avoid brackets
doOperator (Just (1, InfixApp _ _ op _)) InfixApp{} | not $ isDol op = True
doOperator _ _ = False
middle :: (b -> d) -> (a, b, c) -> (a, d, c)
middle f (a,b,c) = (a, f b, c)
-- see through Paren and down if/case etc
-- return the name to use in the hint, and the revised expression
monadCall :: Exp_ -> Maybe (String,Exp_, [Refactoring R.SrcSpan])
monadCall (Paren l x) = middle (Paren l) <$> monadCall x
monadCall (App l x y) = middle (\x -> App l x y) <$> monadCall x
monadCall (InfixApp l x op y)
| isDol op = middle (\x -> InfixApp l x op y) <$> monadCall x
| op ~= ">>=" = middle (InfixApp l x op) <$> monadCall y
monadCall (replaceBranches -> (bs@(_:_), gen)) | all isJust res
= Just ("Use simple functions", gen $ map (\(Just (a,b,c)) -> b) res, rs)
where res = map monadCall bs
rs = concatMap (\(Just (a,b,c)) -> c) res
monadCall x | x2:_ <- filter (x ~=) badFuncs = let x3 = x2 ++ "_" in Just (x3, toNamed x3, [Replace Expr (toSS x) [] x3])
monadCall _ = Nothing
monadReturn :: [Stmt S] -> Maybe ([Stmt S], [Refactoring R.SrcSpan])
monadReturn (reverse -> q@(Qualifier _ (App _ ret (Var _ v))):g@(Generator _ (PVar _ p) x):rest)
| ret ~= "return", fromNamed v == fromNamed p
= Just (reverse (Qualifier an x : rest),
[Replace Stmt (toSS g) [("x", toSS x)] "x", Delete Stmt (toSS q)])
monadReturn _ = Nothing
monadJoin :: [Stmt S] -> String -> Maybe ([Stmt S], [Refactoring R.SrcSpan])
monadJoin (g@(Generator _ (view -> PVar_ p) x):q@(Qualifier _ (view -> Var_ v)):xs) (c:cs)
| p == v && v `notElem` varss xs
= Just . f $ fromMaybe def (monadJoin xs cs)
where
gen expr = Qualifier (ann x) (rebracket1 $ App an (toNamed "join") expr)
def = (xs, [])
f (ss, rs) = (s:ss, r ++ rs)
s = gen x
r = [Replace Stmt (toSS g) [("x", toSS x)] "join x", Delete Stmt (toSS q)]
monadJoin (x:xs) cs = first (x:) <$> monadJoin xs cs
monadJoin [] _ = Nothing
monadLet :: [Stmt S] -> Maybe ([Stmt S], [Refactoring R.SrcSpan])
monadLet xs = if null rs then Nothing else Just (ys, rs)
where
(ys, catMaybes -> rs) = unzip $ map mkLet xs
vs = concatMap pvars [p | Generator _ p _ <- xs]
mkLet g@(Generator _ v@(view -> PVar_ p) (fromRet -> Just y))
| p `notElem` vars y, p `notElem` delete p vs
= (template (toNamed p) y, Just refact)
where
refact = Replace Stmt (toSS g) [("lhs", toSS v), ("rhs", toSS y)]
(prettyPrint $ template (toNamed "lhs") (toNamed "rhs"))
mkLet x = (x, Nothing)
template lhs rhs = LetStmt an $ BDecls an [PatBind an lhs (UnGuardedRhs an rhs) Nothing]
fromRet (Paren _ x) = fromRet x
fromRet (InfixApp _ x y z) | opExp y ~= "$" = fromRet $ App an x z
fromRet (App _ x y) | x ~= "return" = Just y
fromRet _ = Nothing
hlint-2.0.11/src/Hint/Match.hs 0000644 0000000 0000000 00000016576 13210071537 014176 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, ViewPatterns, RecordWildCards, FlexibleContexts, ScopedTypeVariables #-}
{-
The matching does a fairly simple unification between the two terms, treating
any single letter variable on the left as a free variable. After the matching
we substitute, transform and check the side conditions. We also "see through"
both ($) and (.) functions on the right.
TRANSFORM PATTERNS
_eval_ - perform deep evaluation, must be used at the top of a RHS
_noParen_ - don't bracket this particular item
SIDE CONDITIONS
(&&), (||), not - boolean connectives
isAtom x - does x never need brackets
isFoo x - is the root constructor of x a "Foo"
notEq x y - are x and y not equal
notIn xs ys - are all x variables not in ys expressions
noTypeCheck, noQuickCheck - no semantics, a hint for testing only
($) AND (.)
We see through ($)/(.) by expanding it if nothing else matches.
We also see through (.) by translating rules that have (.) equivalents
to separate rules. For example:
concat (map f x) ==> concatMap f x
-- we spot both these rules can eta reduce with respect to x
concat . map f ==> concatMap f
-- we use the associativity of (.) to add
concat . map f . x ==> concatMap f . x
-- currently 36 of 169 rules have (.) equivalents
We see through (.) if the RHS is dull using id, e.g.
not (not x) ==> x
not . not ==> id
not . not . x ==> x
-}
module Hint.Match(readMatch) where
import Control.Applicative
import Data.List.Extra
import Data.Maybe
import Config.Type
import Hint.Type
import Control.Monad
import Data.Tuple.Extra
import HSE.Unify
import qualified Data.Set as Set
import Prelude
import qualified Refact.Types as R
fmapAn = fmap (const an)
---------------------------------------------------------------------
-- READ THE RULE
readMatch :: [HintRule] -> DeclHint
readMatch settings = findIdeas (concatMap readRule settings)
readRule :: HintRule -> [HintRule]
readRule (m@HintRule{hintRuleLHS=(fmapAn -> hintRuleLHS), hintRuleRHS=(fmapAn -> hintRuleRHS), hintRuleSide=(fmap fmapAn -> hintRuleSide)}) =
(:) m{hintRuleLHS=hintRuleLHS,hintRuleSide=hintRuleSide,hintRuleRHS=hintRuleRHS} $ do
(l,v1) <- dotVersion hintRuleLHS
(r,v2) <- dotVersion hintRuleRHS
guard $ v1 == v2 && l /= [] && (length l > 1 || length r > 1) && Set.notMember v1 (freeVars $ maybeToList hintRuleSide ++ l ++ r)
if r /= [] then
[m{hintRuleLHS=dotApps l, hintRuleRHS=dotApps r, hintRuleSide=hintRuleSide}
,m{hintRuleLHS=dotApps (l++[toNamed v1]), hintRuleRHS=dotApps (r++[toNamed v1]), hintRuleSide=hintRuleSide}]
else if length l > 1 then
[m{hintRuleLHS=dotApps l, hintRuleRHS=toNamed "id", hintRuleSide=hintRuleSide}
,m{hintRuleLHS=dotApps (l++[toNamed v1]), hintRuleRHS=toNamed v1, hintRuleSide=hintRuleSide}]
else []
-- find a dot version of this rule, return the sequence of app prefixes, and the var
dotVersion :: Exp_ -> [([Exp_], String)]
dotVersion (view -> Var_ v) | isUnifyVar v = [([], v)]
dotVersion (App l ls rs) = first (ls :) <$> dotVersion (fromParen rs)
dotVersion (InfixApp l x op y) = (first (LeftSection l x op :) <$> dotVersion y) ++
(first (RightSection l op y:) <$> dotVersion x)
dotVersion _ = []
---------------------------------------------------------------------
-- PERFORM THE MATCHING
findIdeas :: [HintRule] -> Scope -> Module S -> Decl_ -> [Idea]
findIdeas matches s _ decl =
[ (idea (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes}
| decl <- case decl of InstDecl{} -> children decl; _ -> [decl]
, (parent,x) <- universeParentExp decl, not $ isParen x
, m <- matches, Just (y,notes, subst) <- [matchIdea s decl m parent x]
, let r = R.Replace R.Expr (toSS x) subst (prettyPrint $ hintRuleRHS m) ]
matchIdea :: Scope -> Decl_ -> HintRule -> Maybe (Int, Exp_) -> Exp_ -> Maybe (Exp_, [Note], [(String, R.SrcSpan)])
matchIdea s decl HintRule{..} parent x = do
let nm a b = scopeMatch (hintRuleScope,a) (s,b)
u <- unifyExp nm True hintRuleLHS x
u <- validSubst (=~=) u
-- need to check free vars before unqualification, but after subst (with e)
-- need to unqualify before substitution (with res)
let e = substitute u hintRuleRHS
res = addBracket parent $ performSpecial $ substitute u $ unqualify hintRuleScope s hintRuleRHS
guard $ (freeVars e Set.\\ Set.filter (not . isUnifyVar) (freeVars hintRuleRHS))
`Set.isSubsetOf` freeVars x
-- check no unexpected new free variables
guard $ checkSide hintRuleSide $ ("original",x) : ("result",res) : fromSubst u
guard $ checkDefine decl parent res
return (res, hintRuleNotes, [(s, toSS pos) | (s, pos) <- fromSubst u, ann pos /= an])
---------------------------------------------------------------------
-- SIDE CONDITIONS
checkSide :: Maybe Exp_ -> [(String, Exp_)] -> Bool
checkSide x bind = maybe True f x
where
f (InfixApp _ x op y)
| opExp op ~= "&&" = f x && f y
| opExp op ~= "||" = f x || f y
f (App _ x y) | x ~= "not" = not $ f y
f (Paren _ x) = f x
f (App _ cond (sub -> y))
| 'i':'s':typ <- fromNamed cond
= isType typ y
f (App _ (App _ cond (sub -> x)) (sub -> y))
| cond ~= "notIn" = and [x `notElem` universe y | x <- list x, y <- list y]
| cond ~= "notEq" = x /=~= y
f x | x ~= "noTypeCheck" = True
f x | x ~= "noQuickCheck" = True
f x = error $ "Hint.Match.checkSide, unknown side condition: " ++ prettyPrint x
isType "Compare" x = True -- just a hint for proof stuff
isType "Atom" x = isAtom x
isType "WHNF" x = isWHNF x
isType "Wildcard" x = any isFieldWildcard $ universeS x
isType "Nat" (asInt -> Just x) | x >= 0 = True
isType "Pos" (asInt -> Just x) | x > 0 = True
isType "Neg" (asInt -> Just x) | x < 0 = True
isType "NegZero" (asInt -> Just x) | x <= 0 = True
isType ('L':'i':'t':typ@(_:_)) (Lit _ x) = head (words $ show x) == typ
isType typ x = head (words $ show x) == typ
asInt :: Exp_ -> Maybe Integer
asInt (Paren _ x) = asInt x
asInt (NegApp _ x) = negate <$> asInt x
asInt (Lit _ (Int _ x _)) = Just x
asInt _ = Nothing
list :: Exp_ -> [Exp_]
list (List _ xs) = xs
list x = [x]
sub :: Exp_ -> Exp_
sub = transform f
where f (view -> Var_ x) | Just y <- lookup x bind = y
f x = x
-- does the result look very much like the declaration
checkDefine :: Decl_ -> Maybe (Int, Exp_) -> Exp_ -> Bool
checkDefine x Nothing y = fromNamed x /= fromNamed (transformBi unqual $ head $ fromApps y)
checkDefine _ _ _ = True
---------------------------------------------------------------------
-- TRANSFORMATION
-- if it has _eval_ do evaluation on it
performSpecial :: Exp_ -> Exp_
performSpecial = transform fNoParen . fEval
where
fEval (App _ e x) | e ~= "_eval_" = reduce x
fEval x = x
fNoParen (App _ e x) | e ~= "_noParen_" = fromParen x
fNoParen x = x
-- contract Data.List.foo ==> foo, if Data.List is loaded
unqualify :: Scope -> Scope -> Exp_ -> Exp_
unqualify from to = transformBi f
where
f x@(UnQual _ (Ident _ s)) | isUnifyVar s = x
f x = scopeMove (from,x) to
addBracket :: Maybe (Int,Exp_) -> Exp_ -> Exp_
addBracket (Just (i,p)) c | needBracket i p c = Paren an c
addBracket _ x = x
hlint-2.0.11/src/Hint/ListRec.hs 0000644 0000000 0000000 00000013516 13210071537 014476 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, ViewPatterns #-}
{-
map f [] = []
map f (x:xs) = f x : map f xs
foldr f z [] = z
foldr f z (x:xs) = f x (foldr f z xs)
foldl f z [] = z
foldl f z (x:xs) = foldl f (f z x) xs
-}
{-
f (x:xs) = negate x + f xs ; f [] = 0 -- f xs = foldr ((+) . negate) 0 xs
f (x:xs) = x + 1 : f xs ; f [] = [] -- f xs = map (+ 1) xs
f z (x:xs) = f (z*x) xs ; f z [] = z -- f z xs = foldl (*) z xs
f a (x:xs) b = x + a + b : f a xs b ; f a [] b = [] -- f a xs b = map (\ x -> x + a + b) xs
f [] a = return a ; f (x:xs) a = a + x >>= \fax -> f xs fax -- f xs a = foldM (+) a xs
foos [] x = x; foos (y:ys) x = foo y $ foos ys x -- foos ys x = foldr foo x ys
f [] y = y; f (x:xs) y = f xs $ g x y -- f xs y = foldl (flip g) y xs
f [] y = y; f (x : xs) y = let z = g x y in f xs z -- f xs y = foldl (flip g) y xs
f [] y = y; f (x:xs) y = f xs (f xs z)
-}
module Hint.ListRec(listRecHint) where
import Hint.Type
import Hint.Util
import Data.List.Extra
import Data.Maybe
import Data.Ord
import Data.Either.Extra
import Control.Monad
import Refact.Types hiding (RType(Match))
listRecHint :: DeclHint
listRecHint _ _ = concatMap f . universe
where
f o = maybeToList $ do
let x = o
(x, addCase) <- findCase x
(use,severity,x) <- matchListRec x
let y = addCase x
guard $ recursiveStr `notElem` varss y
-- Maybe we can do better here maintaining source formatting?
return $ idea severity ("Use " ++ use) o y [Replace Decl (toSS o) [] (prettyPrint y)]
recursiveStr = "_recursive_"
recursive = toNamed recursiveStr
-- recursion parameters, nil-case, (x,xs,cons-case)
-- for cons-case delete any recursive calls with xs from them
-- any recursive calls are marked "_recursive_"
data ListCase = ListCase [String] Exp_ (String,String,Exp_)
deriving Show
data BList = BNil | BCons String String
deriving (Eq,Ord,Show)
-- function name, parameters, list-position, list-type, body (unmodified)
data Branch = Branch String [String] Int BList Exp_
deriving Show
---------------------------------------------------------------------
-- MATCH THE RECURSION
matchListRec :: ListCase -> Maybe (String,Severity,Exp_)
matchListRec o@(ListCase vs nil (x,xs,cons))
| [] <- vs, nil ~= "[]", InfixApp _ lhs c rhs <- cons, opExp c ~= ":"
, fromParen rhs =~= recursive, xs `notElem` vars lhs
= Just $ (,,) "map" Warning $ appsBracket
[toNamed "map", niceLambda [x] lhs, toNamed xs]
| [] <- vs, App2 op lhs rhs <- view cons
, vars op `disjoint` [x,xs]
, fromParen rhs == recursive, xs `notElem` vars lhs
= Just $ (,,) "foldr" Suggestion $ appsBracket
[toNamed "foldr", niceLambda [x] $ appsBracket [op,lhs], nil, toNamed xs]
| [v] <- vs, view nil == Var_ v, App _ r lhs <- cons, r =~= recursive
, xs `notElem` vars lhs
= Just $ (,,) "foldl" Suggestion $ appsBracket
[toNamed "foldl", niceLambda [v,x] lhs, toNamed v, toNamed xs]
| [v] <- vs, App _ ret res <- nil, ret ~= "return", res ~= "()" || view res == Var_ v
, [Generator _ (view -> PVar_ b1) e, Qualifier _ (fromParen -> App _ r (view -> Var_ b2))] <- asDo cons
, b1 == b2, r == recursive, xs `notElem` vars e
, name <- "foldM" ++ ['_' | res ~= "()"]
= Just $ (,,) name Suggestion $ appsBracket
[toNamed name, niceLambda [v,x] e, toNamed v, toNamed xs]
| otherwise = Nothing
-- Very limited attempt to convert >>= to do, only useful for foldM/foldM_
asDo :: Exp_ -> [Stmt S]
asDo (view -> App2 bind lhs (Lambda _ [v] rhs)) = [Generator an v lhs, Qualifier an rhs]
asDo (Do _ x) = x
asDo x = [Qualifier an x]
---------------------------------------------------------------------
-- FIND THE CASE ANALYSIS
findCase :: Decl_ -> Maybe (ListCase, Exp_ -> Decl_)
findCase x = do
FunBind _ [x1,x2] <- return x
Branch name1 ps1 p1 c1 b1 <- findBranch x1
Branch name2 ps2 p2 c2 b2 <- findBranch x2
guard (name1 == name2 && ps1 == ps2 && p1 == p2)
[(BNil, b1), (BCons x xs, b2)] <- return $ sortBy (comparing fst) [(c1,b1), (c2,b2)]
b2 <- transformAppsM (delCons name1 p1 xs) b2
(ps,b2) <- return $ eliminateArgs ps1 b2
let ps12 = let (a,b) = splitAt p1 ps1 in map toNamed $ a ++ xs : b
return (ListCase ps b1 (x,xs,b2)
,\e -> FunBind an [Match an (toNamed name1) ps12 (UnGuardedRhs an e) Nothing])
delCons :: String -> Int -> String -> Exp_ -> Maybe Exp_
delCons func pos var (fromApps -> (view -> Var_ x):xs) | func == x = do
(pre, (view -> Var_ v):post) <- return $ splitAt pos xs
guard $ v == var
return $ apps $ recursive : pre ++ post
delCons _ _ _ x = return x
eliminateArgs :: [String] -> Exp_ -> ([String], Exp_)
eliminateArgs ps cons = (remove ps, transform f cons)
where
args = [zs | z:zs <- map fromApps $ universeApps cons, z =~= recursive]
elim = [all (\xs -> length xs > i && view (xs !! i) == Var_ p) args | (i,p) <- zip [0..] ps] ++ repeat False
remove = concat . zipWith (\b x -> [x | not b]) elim
f (fromApps -> x:xs) | x == recursive = apps $ x : remove xs
f x = x
---------------------------------------------------------------------
-- FIND A BRANCH
findBranch :: Match S -> Maybe Branch
findBranch x = do
Match _ name ps (UnGuardedRhs _ bod) Nothing <- return x
(a,b,c) <- findPat ps
return $ Branch (fromNamed name) a b c $ simplifyExp bod
findPat :: [Pat_] -> Maybe ([String], Int, BList)
findPat ps = do
ps <- mapM readPat ps
[i] <- return $ findIndices isRight ps
let (left,[right]) = partitionEithers ps
return (left, i, right)
readPat :: Pat_ -> Maybe (Either String BList)
readPat (view -> PVar_ x) = Just $ Left x
readPat (PParen _ (PInfixApp _ (view -> PVar_ x) (Special _ Cons{}) (view -> PVar_ xs))) = Just $ Right $ BCons x xs
readPat (PList _ []) = Just $ Right BNil
readPat _ = Nothing
hlint-2.0.11/src/Hint/List.hs 0000644 0000000 0000000 00000011716 13210071537 014044 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-}
{-
Find and match:
yes = 1:2:[] -- [1,2]
yes = ['h','e','l','l','o']
yes (1:2:[]) = 1 -- [1,2]
yes ['h','e'] = 1
-- [a]++b -> a : b, but only if not in a chain of ++'s
yes = [x] ++ xs -- x : xs
no = "x" ++ xs
no = [x] ++ xs ++ ys
no = xs ++ [x] ++ ys
yes = [if a then b else c] ++ xs -- (if a then b else c) : xs
yes = [1] : [2] : [3] : [4] : [5] : [] -- [[1], [2], [3], [4], [5]]
yes = if x == e then l2 ++ xs else [x] ++ check_elem xs -- x : check_elem xs
data Yes = Yes (Maybe [Char]) -- Maybe String
yes = y :: [Char] -> a -- String -> a
instance C [Char]
foo = [a b] ++ xs -- a b : xs
foo = [myexpr | True, a] -- [myexpr | a]
foo = [myexpr | False] -- []
-}
module Hint.List(listHint) where
import Control.Applicative
import Hint.Type
import Data.Maybe
import Prelude
import Refact.Types
listHint :: DeclHint
listHint _ _ = listDecl
listDecl :: Decl_ -> [Idea]
listDecl x =
concatMap (listExp False) (childrenBi x) ++
stringType x ++
concatMap listPat (childrenBi x) ++
concatMap listComp (universeBi x)
listComp :: Exp_ -> [Idea]
listComp o@(ListComp a e xs)
| "False" `elem` cons = [suggest "Short-circuited list comprehension" o (List an []) []]
| "True" `elem` cons = [suggest "Redundant True guards" o o2 []]
where
o2 = ListComp a e $ filter ((/= Just "True") . qualCon) xs
cons = mapMaybe qualCon xs
qualCon (QualStmt _ (Qualifier _ (Con _ x))) = Just $ fromNamed x
qualCon _ = Nothing
listComp _ = []
-- boolean = are you in a ++ chain
listExp :: Bool -> Exp_ -> [Idea]
listExp b (fromParen -> x) =
if null res then concatMap (listExp $ isAppend x) $ children x else [head res]
where
res = [suggest name x x2 [r] | (name,f) <- checks
, Just (x2, subts, temp) <- [f b x]
, let r = Replace Expr (toSS x) subts temp ]
listPat :: Pat_ -> [Idea]
listPat x = if null res then concatMap listPat $ children x else [head res]
where res = [suggest name x x2 [r]
| (name,f) <- pchecks
, Just (x2, subts, temp) <- [f x]
, let r = Replace Pattern (toSS x) subts temp ]
isAppend (view -> App2 op _ _) = op ~= "++"
isAppend _ = False
checks = let (*) = (,) in drop 1 -- see #174
["Use string literal" * useString
,"Use list literal" * useList
,"Use :" * useCons
]
pchecks = let (*) = (,) in drop 1 -- see #174
["Use string literal pattern" * usePString
,"Use list literal pattern" * usePList
]
usePString (PList _ xs) | xs /= [], Just s <- mapM fromPChar xs =
let literal = PLit an (Signless an) $ String an s (show s)
in Just (literal, [], prettyPrint literal)
usePString _ = Nothing
usePList =
fmap ( (\(e, s) -> (PList an e, map (fmap toSS) s, prettyPrint (PList an (map snd s))))
. unzip
)
. f True ['a'..'z']
where
f first _ x | 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 -> Pat_ -> (String, Pat_)
g c p = ([c], PVar (ann p) (toNamed [c]))
useString b (List _ xs) | xs /= [], Just s <- mapM fromChar xs =
let literal = Lit an $ String an s (show s)
in Just (literal , [], prettyPrint literal)
useString b _ = Nothing
useList b =
fmap ( (\(e, s) -> (List an e, map (fmap toSS) s, prettyPrint (List an (map snd s))))
. unzip
)
. f True ['a'..'z']
where
f first _ x | x ~= "[]" = if first then Nothing else Just []
f first (ident:cs) (view -> App2 c a b) | c ~= ":" =
((a, g ident a) :) <$> f False cs b
f first _ _ = Nothing
g :: Char -> Exp_ -> (String, Exp_)
g c p = ([c], toNamed [c])
useCons False (view -> App2 op x y) | op ~= "++"
, Just (x2, build) <- f x
, not $ isAppend y =
Just (gen (build x2) y
, [("x", toSS x2), ("xs", toSS y)]
, prettyPrint $ gen (build $ toNamed "x") (toNamed "xs"))
where
f (List _ [x]) = Just (x, \v -> if isApp x then v else paren v)
f _ = Nothing
gen x = InfixApp an x (QConOp an $ list_cons_name an)
useCons _ _ = Nothing
typeListChar = TyList an (TyCon an (toNamed "Char"))
typeString = TyCon an (toNamed "String")
stringType :: Decl_ -> [Idea]
stringType x = case x of
InstDecl _ _ _ x -> f x
_ -> f x
where
f x = concatMap g $ childrenBi x
g :: Type_ -> [Idea]
g e@(fromTyParen -> x) = [suggest "Use String" x (transform f x)
rs | not . null $ rs]
where f x = if x =~= typeListChar then typeString else x
rs = [Replace Type (toSS t) [] (prettyPrint typeString) | t <- universe x, t =~= typeListChar]
hlint-2.0.11/src/Hint/Lambda.hs 0000644 0000000 0000000 00000015121 13210071537 014303 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns, PatternGuards #-}
{-
Concept:
Remove all the lambdas you can be inserting only sections
Never create a right section with +-# as the operator (they are misparsed)
Rules:
fun a = \x -> y -- promote lambdas, provided no where's outside the lambda
fun x = y x -- eta reduce, x /= mr and foo /= symbol
\x -> y x -- eta reduce
((#) x) ==> (x #) -- rotate operators
(flip op x) ==> (`op` x) -- rotate operators
\x y -> x + y ==> (+) -- insert operator
\x y -> op y x ==> flip op
\x -> x + y ==> (+ y) -- insert section,
\x -> op x y ==> (`op` y) -- insert section
\x -> y + x ==> (y +) -- insert section
\x -> \y -> ... ==> \x y -- lambda compression
\x -> (x +) ==> (+) -- operator reduction
f a = \x -> x + x -- f a x = x + x
f a = \a -> a + a -- f _ a = a + a
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
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 mr = y mr
fun x = f . g $ x -- fun = f . g
f = foo (\y -> g x . h $ y) -- g x . h
f = foo ((*) x) -- (x *)
f = (*) x
f = foo (flip op x) -- (`op` x)
f = flip op x
f = foo (flip (*) x) -- (* x)
f = foo (flip (-) x)
f = foo (\x y -> fun x y) -- @Warning fun
f = foo (\x y -> x + y) -- (+)
f = foo (\x -> x * y) -- @Suggestion (* y)
f = foo (\x -> x # y)
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
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)
f = a b (\x -> c x d) -- (`c` d)
yes = \x -> a x where -- a
yes = \x y -> op y x where -- flip op
f = \y -> nub $ reverse y where -- nub . reverse
f = \z -> foo $ bar $ baz z where -- foo . bar . baz
f = \z -> foo $ bar x $ baz z where -- foo . bar x . baz
f = \z -> foo $ z $ baz z where
f = \x -> bar map (filter x) where -- bar map . filter
f = bar &+& \x -> f (g x)
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)
foo a b c = bar (flux ++ quux) c where flux = c
yes = foo (\x -> Just x) -- @Warning Just
foo = bar (\x -> (x `f`)) -- f
baz = bar (\x -> (x +)) -- (+)
yes = blah (\ x -> case x of A -> a; B -> b) -- \ case A -> a; B -> b
no = blah (\ x -> case x of A -> a x; B -> b x)
-}
module Hint.Lambda(lambdaHint) where
import Hint.Util
import Hint.Type
import Util
import Data.List.Extra
import Data.Maybe
import Refact.Types hiding (RType(Match))
lambdaHint :: DeclHint
lambdaHint _ _ x = concatMap (uncurry lambdaExp) (universeParentBi x) ++ concatMap lambdaDecl (universe x)
lambdaDecl :: Decl_ -> [Idea]
lambdaDecl (toFunBind -> o@(FunBind loc1 [Match _ name pats (UnGuardedRhs loc2 bod) bind]))
| isNothing bind, isLambda $ fromParen bod, null (universeBi pats :: [Exp_]) =
[warn "Redundant lambda" o (gen pats bod) [Replace Decl (toSS o) s1 t1]]
| length pats2 < length pats, pvars (drop (length pats2) pats) `disjoint` varss bind
= [warn "Eta reduce" (reform pats bod) (reform pats2 bod2)
[ -- Disabled, see apply-refact #3
-- Replace Decl (toSS $ reform pats bod) s2 t2]]
]]
where reform p b = FunBind loc [Match an name p (UnGuardedRhs an b) Nothing]
loc = setSpanInfoEnd loc1 $ srcSpanEnd $ srcInfoSpan loc2
gen ps = uncurry reform . fromLambda . Lambda an ps
(finalpats, body) = fromLambda . Lambda an pats $ bod
(pats2, bod2) = etaReduce pats bod
template fps b = prettyPrint $ reform (zipWith munge ['a'..'z'] fps) (toNamed "body")
munge :: Char -> Pat_ -> Pat_
munge ident p@(PWildCard _) = p
munge ident p = PVar (ann p) (Ident (ann p) [ident])
subts fps b = ("body", toSS b) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS fps)
s1 = subts finalpats body
--s2 = subts pats2 bod2
t1 = template finalpats body
--t2 = template pats2 bod2
lambdaDecl _ = []
setSpanInfoEnd ssi (line, col) = ssi{srcInfoSpan = (srcInfoSpan ssi){srcSpanEndLine=line, srcSpanEndColumn=col}}
etaReduce :: [Pat_] -> Exp_ -> ([Pat_], Exp_)
etaReduce ps (App _ x (Var _ (UnQual _ (Ident _ y))))
| ps /= [], PVar _ (Ident _ p) <- last ps, p == y, p /= "mr", y `notElem` vars x
= etaReduce (init ps) x
etaReduce ps (InfixApp a x (isDol -> True) y) = etaReduce ps (App a x y)
etaReduce ps x = (ps,x)
--Section refactoring is not currently implemented.
lambdaExp :: Maybe Exp_ -> Exp_ -> [Idea]
lambdaExp p o@(Paren _ (App _ v@(Var l (UnQual _ (Symbol _ x))) y)) | isAtom y, allowLeftSection x =
[suggestN "Use section" o (exp y x)] -- [Replace Expr (toSS o) subts template]]
where
exp op rhs = LeftSection an op (toNamed rhs)
-- template = prettyPrint (exp (toNamed "a") "*")
-- subts = [("a", toSS y), ("*", toSS v)]
lambdaExp p o@(Paren _ (App _ (App _ (view -> Var_ "flip") (Var _ x)) y)) | allowRightSection $ fromNamed x =
[suggestN "Use section" o $ RightSection an (QVarOp an x) y]
lambdaExp p o@Lambda{} | maybe True (not . isInfixApp) p, (res, refact) <- niceLambdaR [] o, not $ isLambda res =
[(if isVar res || isCon res then warn else suggest) "Avoid lambda" o res (refact $ toSS o)]
lambdaExp p o@(Lambda _ pats x) | isLambda (fromParen x), null (universeBi pats :: [Exp_]), maybe True (not . isLambda) p =
[suggest "Collapse lambdas" o (Lambda an pats body) [Replace Expr (toSS o) subts template]]
where
(pats, body) = fromLambda o
template = prettyPrint $ Lambda an (zipWith munge ['a'..'z'] pats) (toNamed "body")
munge :: Char -> Pat_ -> Pat_
munge ident p@(PWildCard _) = p
munge ident p = PVar (ann p) (Ident (ann p) [ident])
subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS pats)
lambdaExp p o@(Lambda _ [view -> PVar_ u] (Case _ (view -> Var_ v) alts))
| u == v, u `notElem` vars alts = [suggestN "Use lambda-case" o $ LCase an alts]
lambdaExp _ _ = []
-- replace any repeated pattern variable with _
fromLambda :: Exp_ -> ([Pat_], Exp_)
fromLambda (Lambda _ ps1 (fromLambda . fromParen -> (ps2,x))) = (transformBi (f $ pvars ps2) ps1 ++ ps2, x)
where f bad x@PVar{} | prettyPrint x `elem` bad = PWildCard an
f bad x = x
fromLambda x = ([], x)
hlint-2.0.11/src/Hint/Import.hs 0000644 0000000 0000000 00000032170 13210071537 014400 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards #-}
{-
Reduce the number of import declarations.
Two import declarations can be combined if:
(note, A[] is A with whatever import list, or none)
import A[]; import A[] = import A[]
import A(B); import A(C) = import A(B,C)
import A; import A(C) = import A
import A; import A hiding (C) = import A
import A[]; import A[] as Y = import A[] as Y
import A; import A -- import A
import A; import A; import A -- import A
import A(Foo) ; import A -- import A
import A ;import A(Foo) -- import A
import A(Bar(..)); import {-# SOURCE #-} A
import A; import B
import A(B) ; import A(C) -- import A(B,C)
import A; import A hiding (C) -- import A
import A; import A as Y -- import A as Y
import A; import qualified A as Y
import A as B; import A as C
import A as A -- import A
import qualified A as A -- import qualified A
import A; import B; import A -- import A
import qualified A; import A
import B; import A; import A -- import A
import A hiding(Foo); import A hiding(Bar)
import List -- import Data.List
import qualified List -- import qualified Data.List as List
import Char(foo) -- import Data.Char(foo)
import IO(foo)
import IO as X -- import System.IO as X; import System.IO.Error as X; import Control.Exception as X (bracket,bracket_)
import A hiding (a) -- import A
import A hiding (a, b); foo = a -- import A hiding (a)
import A hiding (a, b); foo = A.a -- import A hiding (a)
import A as B hiding (a) -- import A as B
import A as B hiding (a, b); foo = a -- import A as B hiding (a)
import A as B hiding (a, b); foo = B.a -- import A as B hiding (a)
import qualified A hiding (a) -- import qualified A
import qualified A hiding (a, b); foo = A.a -- import qualified A hiding (a)
import qualified A as B hiding (a, b); foo = B.a -- import qualified A as B hiding (a)
import A hiding ((+)) -- import A
import A hiding ((+), (*)); foo = (+) -- import A hiding ((+))
import A hiding ((+), (*)); foo = (+x) -- import A hiding ((+))
import A hiding ((+), (*)); foo = (x+) -- import A hiding ((+))
import A hiding ((+), (*)); foo = x+y -- import A hiding ((+))
import A hiding ((+), (*)); foo = (A.+) -- import A hiding ((+))
import A hiding ((+), (*)); foo = (A.+ x) -- import A hiding ((+))
import A hiding ((+), (*)); foo = (x A.+) -- import A hiding ((+))
import A hiding ((+), (*)); foo = x A.+ y -- import A hiding ((+))
import A as B hiding ((+)) -- import A as B
import A as B hiding ((+), (*)); foo = (+) -- import A as B hiding ((+))
import A as B hiding ((+), (*)); foo = (x+) -- import A as B hiding ((+))
import A as B hiding ((+), (*)); foo = (+x) -- import A as B hiding ((+))
import A as B hiding ((+), (*)); foo = x+y -- import A as B hiding ((+))
import A as B hiding ((+), (*)); foo = (B.+) -- import A as B hiding ((+))
import A as B hiding ((+), (*)); foo = (x B.+) -- import A as B hiding ((+))
import A as B hiding ((+), (*)); foo = (B.+ x) -- import A as B hiding ((+))
import A as B hiding ((+), (*)); foo = x B.+ y -- import A as B hiding ((+))
import qualified A hiding ((+)) -- import qualified A
import qualified A hiding ((+), (*)); foo = (A.+) -- import qualified A hiding ((+))
import qualified A hiding ((+), (*)); foo = (x A.+) -- import qualified A hiding ((+))
import qualified A hiding ((+), (*)); foo = (A.+ x) -- import qualified A hiding ((+))
import qualified A hiding ((+), (*)); foo = x A.+ y -- import qualified A hiding ((+))
import qualified A as B hiding ((+), (*)); foo = (B.+) -- import qualified A as B hiding ((+))
import qualified A as B hiding ((+), (*)); foo = (x B.+) -- import qualified A as B hiding ((+))
import qualified A as B hiding ((+), (*)); foo = (B.+ x) -- import qualified A as B hiding ((+))
import qualified A as B hiding ((+), (*)); foo = x B.+ y -- import qualified A as B hiding ((+))
module Foo (a) where; import A hiding (a)
module Foo (a) where; import A hiding (a, b) -- import A hiding (a)
module Foo (A.a) where; import A hiding (a, b) -- import A hiding (a)
module Foo (a) where; import A as B hiding (a)
module Foo (a) where; import A as B hiding (a, b) -- import A as B hiding (a)
module Foo (B.a) where; import A as B hiding (a, b) -- import A as B hiding (a)
module Foo (a) where; import qualified A hiding (a) -- import qualified A
module Foo (A.a) where; import qualified A hiding (a, b) -- import qualified A hiding (a)
module Foo (B.a) where; import qualified A as B hiding (a, b) -- import qualified A as B hiding (a)
module Foo (module A) where; import A hiding (a, b, c)
module Foo (module B) where; import A as B hiding (a, b, c)
module Foo (module A) where; import qualified A hiding (a, b, c) -- import qualified A
module Foo (module B) where; import qualified A as B hiding (a, b, c) -- import qualified A as B
module Foo ((+)) where; import A hiding ((+))
module Foo ((+)) where; import A hiding ((+), (*)) -- import A hiding ((+))
module Foo ((A.+)) where; import A hiding ((+), (*)) -- import A hiding ((+))
module Foo ((+)) where; import A as B hiding ((+))
module Foo ((+)) where; import A as B hiding ((+), (*)) -- import A as B hiding ((+))
module Foo ((B.+)) where; import A as B hiding ((+), (*)) -- import A as B hiding ((+))
module Foo ((+)) where; import qualified A hiding ((+)) -- import qualified A
module Foo ((A.+)) where; import qualified A hiding ((+), (*)) -- import qualified A hiding ((+))
module Foo ((B.+)) where; import qualified A as B hiding ((+), (*)) -- import qualified A as B hiding ((+))
module Foo (module A) where; import A hiding ((+), (*), (/))
module Foo (module B) where; import A as B hiding ((+), (*), (/))
module Foo (module A) where; import qualified A hiding ((+), (*), (/)) -- import qualified A
module Foo (module B) where; import qualified A as B hiding ((+), (*), (/)) -- import qualified A as B
{-# LANGUAGE QuasiQuotes #-}; import A hiding (a); [a||]
{-# LANGUAGE QuasiQuotes #-}; import A hiding (a); [A.a||]
{-# LANGUAGE QuasiQuotes #-}; import A as B hiding (a); [B.a||]
{-# LANGUAGE QuasiQuotes #-}; import qualified A hiding (a); [A.a||]
{-# LANGUAGE QuasiQuotes #-}; import qualified A as B hiding (a); [B.a||]
-}
module Hint.Import(importHint) where
import Control.Applicative
import Data.Tuple.Extra
import Hint.Type
import Refact.Types hiding (ModuleName)
import qualified Refact.Types as R
import Data.List.Extra
import Data.Either (partitionEithers)
import Data.Maybe
import Prelude
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
importHint :: ModuHint
importHint _ x = concatMap (wrap . snd) (groupSort
[((fromNamed $ importModule i,importPkg i),i) | i <- universeBi x, not $ importSrc i]) ++
concatMap (\x -> hierarchy x ++ combine1 x ++ hidden reexported unqual quals x) (universeBi x)
where
-- Names of all re-exported modules
reexported :: Set String
reexported = Set.fromList [ fromModuleName n | EModuleContents _ n <- universeBi x ]
-- Unqualified expressions and exported expressions
unqual :: Set String
unqual = Set.fromList (mapMaybe f qnames) `Set.union` Set.fromList qqUnqual
where f :: QName S -> Maybe String
f (UnQual _ n) = Just (fromNamed n)
f _ = Nothing
-- Qualified expressions and exported expressions
quals :: Map String (Set String)
quals = Map.fromListWith Set.union (map (second Set.singleton) qqQuals ++ mapMaybe f qnames)
where f (Qual _ m n) = Just (fromModuleName m, Set.singleton (fromNamed n))
f _ = Nothing
-- Unqualified quasi-quoters like [foo|...|]
qqUnqual :: [String]
-- Qualified quasi-quoters like [Foo.bar|...|]
qqQuals :: [(String, String)]
(qqUnqual, qqQuals) = partitionEithers [ f n | QuasiQuote (_ :: S) n _ <- universeBi x ]
where f :: String -> Either String (String, String)
f n = maybe (Left n) Right (stripInfixEnd "." n)
qnames :: [QName S]
qnames = concat
[ [ n | Var (_ :: S) n <- universeBi x ]
, [ n | VarQuote (_ :: S) n <- universeBi x ]
, [ n | QVarOp (_ :: S) n <- universeBi x ]
, [ n | EVar (_ :: S) n <- universeBi x ]
]
wrap :: [ImportDecl S] -> [Idea]
wrap o = [ rawIdea Warning "Use fewer imports" (srcInfoSpan $ ann $ head o) (f o) (Just $ f x) [] rs
| Just (x, rs) <- [simplify o]]
where f = unlines . map prettyPrint
simplify :: [ImportDecl S] -> Maybe ([ImportDecl S], [Refactoring R.SrcSpan])
simplify [] = Nothing
simplify (x:xs) = case simplifyHead x xs of
Nothing -> first (x:) <$> simplify xs
Just (xs, rs) -> Just $ maybe (xs, rs) (second (++ rs)) $ simplify xs
simplifyHead :: ImportDecl S -> [ImportDecl S] -> Maybe ([ImportDecl S], [Refactoring R.SrcSpan])
simplifyHead x [] = Nothing
simplifyHead x (y:ys) = case combine x y of
Nothing -> first (y:) <$> simplifyHead x ys
Just (xy, rs) -> Just (xy : ys, rs)
combine :: ImportDecl S -> ImportDecl S -> Maybe (ImportDecl S, [Refactoring R.SrcSpan])
combine x y | qual, as, specs = Just (x, [Delete Import (toSS y)])
| qual, as, Just (ImportSpecList _ False xs) <- importSpecs x, Just (ImportSpecList _ False ys) <- importSpecs y = let newImp = x{importSpecs = Just $ ImportSpecList an False $ nub_ $ xs ++ ys}
in Just (newImp, [ Replace Import (toSS x) [] (prettyPrint newImp)
, Delete Import (toSS y) ] )
| qual, as, isNothing (importSpecs x) || isNothing (importSpecs y) =
let (newImp, toDelete) = if isNothing (importSpecs x) then (x, y) else (y, x)
in Just (newImp, [Delete Import (toSS toDelete)])
| not (importQualified x), qual, specs, length ass == 1 =
let (newImp, toDelete) = if isJust (importAs x) then (x, y) else (y, x)
in Just (newImp, [Delete Import (toSS toDelete)])
where
qual = importQualified x == importQualified y
as = importAs x `eqMaybe` importAs y
ass = mapMaybe importAs [x,y]
specs = importSpecs x `eqMaybe` importSpecs y
combine _ _ = Nothing
combine1 :: ImportDecl S -> [Idea]
combine1 i@ImportDecl{..}
| Just (dropAnn importModule) == fmap dropAnn importAs
= [suggest "Redundant as" i i{importAs=Nothing} [RemoveAsKeyword (toSS i)]]
combine1 _ = []
newNames = let (*) = flip (,) in
["Control" * "Monad"
,"Data" * "Char"
,"Data" * "List"
,"Data" * "Maybe"
,"Data" * "Ratio"
,"System" * "Directory"
-- Special, see bug #393
-- ,"System" * "IO"
-- Do not encourage use of old-locale/old-time over haskell98
-- ,"System" * "Locale"
-- ,"System" * "Time"
]
hierarchy :: ImportDecl S -> [Idea]
hierarchy i@ImportDecl{importModule=m@(ModuleName _ x),importPkg=Nothing} | Just y <- lookup x newNames
=
let newModuleName = y ++ "." ++ x
r = [Replace R.ModuleName (toSS m) [] newModuleName] in
[suggest "Use hierarchical imports" i (desugarQual i){importModule=ModuleName an newModuleName} r]
-- import IO is equivalent to
-- import System.IO, import System.IO.Error, import Control.Exception(bracket, bracket_)
hierarchy i@ImportDecl{importModule=ModuleName _ "IO", importSpecs=Nothing,importPkg=Nothing}
= [rawIdeaN Suggestion "Use hierarchical imports" (srcInfoSpan $ ann i) (trimStart $ prettyPrint i) (
Just $ unlines $ map (trimStart . prettyPrint)
[f "System.IO" Nothing, f "System.IO.Error" Nothing
,f "Control.Exception" $ Just $ ImportSpecList an False [IVar an $ toNamed x | x <- ["bracket","bracket_"]]]) []]
where f a b = (desugarQual i){importModule=ModuleName an a, importSpecs=b}
hierarchy _ = []
-- import qualified X ==> import qualified X as X
desugarQual :: ImportDecl S -> ImportDecl S
desugarQual x | importQualified x && isNothing (importAs x) = x{importAs=Just (importModule x)}
| otherwise = x
-- Suggest removing unnecessary "hiding" clauses in imports. Currently this only
-- works for expressions.
hidden :: Set String -> Set String -> Map String (Set String) -> ImportDecl S -> [Idea]
hidden reexported unqual quals i@ImportDecl{importSpecs = Just (ImportSpecList loc True xs)}
-- If the module is re-exported and not imported qualified, we can't prune
-- any identifiers from the hiding clause
| not (importQualified i) && as `Set.member` reexported = []
| otherwise =
case partition isUsed xs of
(_, []) -> []
([], _) -> [suggest "Unnecessary hiding" i i{importSpecs = Nothing} [Delete Import (toSS i)]]
(xs, _) ->
let newImp = i{importSpecs = Just (ImportSpecList loc True xs)}
in [suggest "Unnecessary hiding" i newImp [Replace Import (toSS i) [] (prettyPrint newImp)]]
where
isUsed :: ImportSpec S -> Bool
isUsed (IVar _ n) = Set.member (fromNamed n) vars
isUsed _ = True
vars :: Set String
vars =
if importQualified i
then qual
else qual `Set.union` unqual
qual :: Set String
qual = fromMaybe Set.empty (Map.lookup as quals)
as :: String
as = fromModuleName (fromMaybe (importModule i) (importAs i))
hidden _ _ _ _ = []
hlint-2.0.11/src/Hint/Extensions.hs 0000644 0000000 0000000 00000024341 13210071537 015266 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards #-}
{-
Suggest removal of unnecessary extensions
i.e. They have {-# LANGUAGE RecursiveDo #-} but no mdo keywords
{-# LANGUAGE Arrows #-} \
f = id --
{-# LANGUAGE TotallyUnknown #-} \
f = id
{-# LANGUAGE Foo, ParallelListComp, ImplicitParams #-} \
f = [(a,c) | a <- b | c <- d] -- {-# LANGUAGE Foo, ParallelListComp #-}
{-# LANGUAGE EmptyDataDecls #-} \
data Foo
{-# LANGUAGE TemplateHaskell #-} \
$(deriveNewtypes typeInfo)
{-# LANGUAGE TemplateHaskell #-} \
main = foo ''Bar
{-# LANGUAGE PatternGuards #-} \
test = case x of _ | y <- z -> w
{-# LANGUAGE TemplateHaskell,EmptyDataDecls #-} \
$(fmap return $ dataD (return []) (mkName "Void") [] [] [])
{-# LANGUAGE RecursiveDo #-} \
main = mdo x <- y; return y
{-# LANGUAGE RecursiveDo #-} \
main = do {rec {x <- return 1}; print x}
{-# LANGUAGE ImplicitParams, BangPatterns #-} \
sort :: (?cmp :: a -> a -> Bool) => [a] -> [a] \
sort !f = undefined
{-# LANGUAGE KindSignatures #-} \
data Set (cxt :: * -> *) a = Set [a]
{-# LANGUAGE RecordWildCards #-} \
record field = Record{..}
{-# LANGUAGE RecordWildCards #-} \
record = 1 --
{-# LANGUAGE UnboxedTuples #-} \
record = 1 --
{-# LANGUAGE TemplateHaskell #-} \
foo
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \
record = 1 --
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \
newtype Foo = Foo Int deriving Data -- {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \
data Foo = Foo Int deriving Data -- {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \
newtype Foo = Foo Int deriving Class -- {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \
data Foo = Foo Int deriving Class --
{-# LANGUAGE DeriveFunctor #-} \
data Foo = Foo Int deriving Functor
{-# LANGUAGE DeriveFunctor #-} \
newtype Foo = Foo Int deriving Functor
{-# LANGUAGE GeneralizedNewtypeDeriving #-} \
newtype Foo = Foo Int deriving Functor
{-# LANGUAGE GeneralizedNewtypeDeriving #-} \
newtype Foo = Foo Int deriving Data --
{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving, StandaloneDeriving #-} \
deriving instance Functor Bar
{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving, StandaloneDeriving #-} \
deriving instance Show Bar -- {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} \
newtype Micro = Micro Int deriving Generic -- {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} \
instance Class Int where {newtype MyIO a = MyIO a deriving NewClass}
{-# LANGUAGE UnboxedTuples #-} \
f :: Int -> (# Int, Int #)
{-# LANGUAGE UnboxedTuples #-} \
f :: x -> (x, x); f x = (x, x) --
{-# LANGUAGE DefaultSignatures #-} \
class Val a where; val :: a --
{-# LANGUAGE DefaultSignatures #-} \
class Val a where; val :: a; default val :: Int
{-# LANGUAGE TypeApplications #-} \
foo = id --
{-# LANGUAGE TypeApplications #-} \
foo = id @Int
{-# LANGUAGE LambdaCase #-} \
foo = id --
{-# LANGUAGE LambdaCase #-} \
foo = \case () -> ()
{-# LANGUAGE NumDecimals #-} \
foo = 12.3e2
{-# LANGUAGE NumDecimals #-} \
foo = id --
{-# LANGUAGE NumDecimals #-} \
foo = 12.345e2 --
{-# LANGUAGE TupleSections #-} \
main = map (,1,2) xs
{-# LANGUAGE TupleSections #-} \
main = id --
{-# LANGUAGE OverloadedStrings #-} \
main = "test"
{-# LANGUAGE OverloadedStrings #-} \
main = id --
{-# LANGUAGE DeriveAnyClass #-} \
main = id --
{-# LANGUAGE DeriveAnyClass #-} \
data Foo = Foo deriving Bob
{-# LANGUAGE DeriveAnyClass #-} \
data Foo a = Foo a deriving (Eq,Data,Functor) --
{-# LANGUAGE MagicHash #-} \
foo# = id
{-# LANGUAGE MagicHash #-} \
main = "foo"#
{-# LANGUAGE MagicHash #-} \
main = 5#
{-# LANGUAGE MagicHash #-} \
main = 'a'#
{-# LANGUAGE MagicHash #-} \
main = 5.6#
{-# LANGUAGE MagicHash #-} \
foo = id --
-}
module Hint.Extensions(extensionsHint) where
import Hint.Type
import Control.Monad.Extra
import Data.Maybe
import Data.List.Extra
import Data.Ratio
import Data.Data
import Refact.Types
import Data.Monoid
import Prelude
extensionsHint :: ModuHint
extensionsHint _ x = [rawIdea Warning "Unused LANGUAGE pragma" (srcInfoSpan sl)
(prettyPrint o) (Just newPragma)
(warnings old new) [refact]
| not $ used TemplateHaskell x -- if TH is on, can use all other extensions programmatically
, o@(LanguagePragma sl exts) <- modulePragmas x
, let old = map (parseExtension . prettyPrint) exts
, let new = minimalExtensions x old
, let newPragma = if null new then "" else prettyPrint $ LanguagePragma sl $ map (toNamed . prettyExtension) new
, let refact = ModifyComment (toSS o) newPragma
, sort new /= sort old]
minimalExtensions :: Module_ -> [Extension] -> [Extension]
minimalExtensions x es = nub $ concatMap f es
where f e = [e | usedExt e x]
-- RecordWildCards implies DisambiguateRecordFields, but most people probably don't want it
warnings old new | wildcards `elem` old && wildcards `notElem` new = [Note "you may need to add DisambiguateRecordFields"]
where wildcards = EnableExtension RecordWildCards
warnings _ _ = []
deriveHaskell = ["Eq","Ord","Enum","Ix","Bounded","Read","Show"]
deriveGenerics = ["Data","Typeable","Generic","Generic1","Lift"]
deriveCategory = ["Functor","Foldable","Traversable"]
-- | Classes that can't require newtype deriving
noGeneralizedNewtypeDeriving =
delete "Enum" deriveHaskell ++ -- Enum can't always be derived on a newtype
deriveGenerics -- Generics stuff can't newtype derive since it has the ctor in it
-- | Classes that can't require DeriveAnyClass
noDeriveAnyClass = deriveHaskell ++ deriveGenerics ++ deriveCategory
usedExt :: Extension -> Module_ -> Bool
usedExt (EnableExtension x) = used x
usedExt (UnknownExtension "NumDecimals") = hasS isWholeFrac
usedExt (UnknownExtension "DeriveLift") = hasDerive ["Lift"]
usedExt (UnknownExtension "DeriveAnyClass") =
any (`notElem` noDeriveAnyClass) .
(\Derives{..} -> derivesNewType ++ derivesData) . derives
usedExt _ = const True
used :: KnownExtension -> Module_ -> Bool
used RecursiveDo = hasS isMDo ||^ hasS isRecStmt
used ParallelListComp = hasS isParComp
used FunctionalDependencies = hasT (un :: FunDep S)
used ImplicitParams = hasT (un :: IPName S)
used TypeApplications = hasS isTypeApp
used EmptyDataDecls = hasS f
where f (DataDecl _ _ _ _ [] _) = True
f (GDataDecl _ _ _ _ _ [] _) = True
f _ = False
used KindSignatures = hasT (un :: Kind S)
used BangPatterns = hasS isPBangPat
used TemplateHaskell = hasT2 (un :: (Bracket S, Splice S)) ||^ hasS f ||^ hasS isSpliceDecl
where f VarQuote{} = True
f TypQuote{} = True
f _ = False
used ForeignFunctionInterface = hasT (un :: CallConv S)
used PatternGuards = hasS f
where f (GuardedRhs _ xs _) = g xs
g [] = False
g [Qualifier{}] = False
g _ = True
used StandaloneDeriving = hasS isDerivDecl
used PatternSignatures = hasS isPatTypeSig
used RecordWildCards = hasS isPFieldWildcard ||^ hasS isFieldWildcard
used RecordPuns = hasS isPFieldPun ||^ hasS isFieldPun
used UnboxedTuples = has (not . isBoxed)
used PackageImports = hasS (isJust . importPkg)
used QuasiQuotes = hasS isQuasiQuote ||^ hasS isTyQuasiQuote
used ViewPatterns = hasS isPViewPat
used DefaultSignatures = hasS isClsDefSig
used DeriveDataTypeable = hasDerive ["Data","Typeable"]
used DeriveFunctor = hasDerive ["Functor"]
used DeriveFoldable = hasDerive ["Foldable"]
used DeriveTraversable = hasDerive ["Traversable"]
used DeriveGeneric = hasDerive ["Generic","Generic1"]
used GeneralizedNewtypeDeriving =
any (`notElem` noGeneralizedNewtypeDeriving) .
(\Derives{..} -> derivesNewType ++ derivesStandalone) . derives
used LambdaCase = hasS isLCase
used TupleSections = hasS isTupleSection
used OverloadedStrings = hasS isString
used Arrows = hasS f
where f Proc{} = True
f LeftArrApp{} = True
f RightArrApp{} = True
f LeftArrHighApp{} = True
f RightArrHighApp{} = True
f _ = False
used TransformListComp = hasS f
where f QualStmt{} = False
f _ = True
used MagicHash = hasS f ||^ hasS isPrimLiteral
where f (Ident _ s) = "#" `isSuffixOf` s
f _ = False
-- for forwards compatibility, if things ever get added to the extension enumeration
used x = usedExt $ UnknownExtension $ show x
hasDerive :: [String] -> Module_ -> Bool
hasDerive want m = any (`elem` want) $ derivesNewType ++ derivesData ++ derivesStandalone
where Derives{..} = derives m
data Derives = Derives
{derivesNewType :: [String]
,derivesData :: [String]
,derivesStandalone :: [String]
}
instance Monoid Derives where
mempty = Derives [] [] []
mappend (Derives x1 x2 x3) (Derives y1 y2 y3) =
Derives (x1++y1) (x2++y2) (x3++y3)
-- | What is derived on newtype, and on data type
-- 'deriving' declarations may be on either, so we approximate as both newtype and data
derives :: Module_ -> Derives
derives m = mconcat $ map decl (childrenBi m) ++ map idecl (childrenBi m)
where
idecl :: InstDecl S -> Derives
idecl (InsData _ dn _ _ ds) = g dn ds
idecl (InsGData _ dn _ _ _ ds) = g dn ds
idecl _ = mempty
decl :: Decl_ -> Derives
decl (DataDecl _ dn _ _ _ ds) = g dn ds
decl (GDataDecl _ dn _ _ _ _ ds) = g dn ds
decl (DataInsDecl _ dn _ _ ds) = g dn ds
decl (GDataInsDecl _ dn _ _ _ ds) = g dn ds
decl (DerivDecl _ _ hd) = mempty{derivesStandalone=[ir hd]}
decl _ = mempty
g dn ds = if isNewType dn then mempty{derivesNewType=xs} else mempty{derivesData=xs}
where xs = maybe [] (map ir . fromDeriving) ds
ir (IRule _ _ _ x) = ih x
ir (IParen _ x) = ir x
ih (IHCon _ a) = prettyPrint $ unqual a
ih (IHInfix _ _ a) = prettyPrint $ unqual a
ih (IHParen _ a) = ih a
ih (IHApp _ a _) = ih a
un = undefined
hasT t x = not $ null (universeBi x `asTypeOf` [t])
hasT2 ~(t1,t2) = hasT t1 ||^ hasT t2
hasS :: (Data x, Data (f S)) => (f S -> Bool) -> x -> Bool
hasS test = any test . universeBi
has f = any f . universeBi
-- Only whole number fractions are permitted by NumDecimals extension.
-- Anything not-whole raises an error.
isWholeFrac :: Literal S -> Bool
isWholeFrac (Frac _ v _) = denominator v == 1
isWholeFrac _ = False
hlint-2.0.11/src/Hint/Export.hs 0000644 0000000 0000000 00000001725 13210071537 014411 0 ustar 00 0000000 0000000 {-
Suggest using better export declarations
main = 1
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
module Foo(module Foo, foo) where foo = 1 -- module Foo(..., foo) where
-}
module Hint.Export(exportHint) where
import Hint.Type
exportHint :: ModuHint
exportHint _ (Module _ (Just o@(ModuleHead a name warning exports)) _ _ _)
| Nothing <- exports =
let o2 = ModuleHead a name warning $ Just $ ExportSpecList a [EModuleContents a name]
in [(ignore "Use module export list" o o2 []){ideaNote = [Note "An explicit list is usually better"]}]
| Just (ExportSpecList _ xs) <- exports, EModuleContents a name `elem_` xs =
let o2 = ModuleHead a name warning $ Just $ ExportSpecList a $ EVar a ellipses : delete_ (EModuleContents a name) xs
in [ignore "Use explicit module export list" o o2 []]
exportHint _ _ = []
hlint-2.0.11/src/Hint/Duplicate.hs 0000644 0000000 0000000 00000005162 13210071537 015041 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
{-
Find bindings within a let, and lists of statements
If you have n the same, error out
main = do a; a; a; a
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
foo = a where {a = 1; b = 2; c = 3}; bar = a where {a = 1; b = 2; c = 3} -- ???
-}
module Hint.Duplicate(duplicateHint) where
import Hint.Type
import Data.Tuple.Extra
import Data.List hiding (find)
import qualified Data.Map as Map
duplicateHint :: CrossHint
duplicateHint ms =
dupes [y | Do _ y :: Exp S <- universeBi modu] ++
dupes [y | BDecls l y :: Binds S <- universeBi modu]
where modu = map snd ms
dupes ys =
[rawIdeaN
(if length xs >= 5 then Warning else Suggestion)
"Reduce duplication" p1
(unlines $ map (prettyPrint . fmap (const p1)) xs)
(Just $ "Combine with " ++ showSrcLoc (getPointLoc p2)) []
| (p1,p2,xs) <- duplicateOrdered 3 $ map (map (srcInfoSpan . ann &&& dropAnn)) ys]
---------------------------------------------------------------------
-- DUPLICATE FINDING
-- | The position to return if we match at this point, and the map of where to go next
-- If two runs have the same vals, always use the first pos you find
data Dupe pos val = Dupe pos (Map.Map val (Dupe pos val))
find :: Ord val => [val] -> Dupe pos val -> (pos, Int)
find (v:vs) (Dupe p mp) | Just d <- Map.lookup v mp = second (+1) $ find vs d
find _ (Dupe p mp) = (p, 0)
add :: Ord val => pos -> [val] -> Dupe pos val -> Dupe pos val
add pos [] d = d
add pos (v:vs) (Dupe p mp) = Dupe p $ Map.insertWith f v (add pos vs $ Dupe pos Map.empty) mp
where f new = add pos vs
duplicateOrdered :: Ord val => Int -> [[(SrcSpan,val)]] -> [(SrcSpan,SrcSpan,[val])]
duplicateOrdered threshold xs = concat $ concat $ snd $ mapAccumL f (Dupe def Map.empty) xs
where
f d xs = second overlaps $ mapAccumL (g pos) d $ takeWhile ((>= threshold) . length) $ tails xs
where pos = Map.fromList $ zip (map fst xs) [0..]
g pos d xs = (d2, res)
where
res = [(p,pme,take mx vs) | i >= threshold
,let mx = maybe i (\x -> min i $ (pos Map.! pme) - x) $ Map.lookup p pos
,mx >= threshold]
vs = map snd xs
(p,i) = find vs d
pme = fst $ head xs
d2 = add pme vs d
overlaps (x@((_,_,n):_):xs) = x : overlaps (drop (length n - 1) xs)
overlaps (x:xs) = x : overlaps xs
overlaps [] = []
hlint-2.0.11/src/Hint/Comment.hs 0000644 0000000 0000000 00000002233 13210071537 014525 0 ustar 00 0000000 0000000
{-
{- MISSING HASH #-} -- {-# MISSING HASH #-}
{- INLINE X -}
{- INLINE Y -} -- {-# INLINE Y #-}
{- INLINE[~k] f -} -- {-# INLINE[~k] f #-}
{- NOINLINE Y -} -- {-# NOINLINE Y #-}
{- UNKNOWN Y -}
INLINE X
-}
module Hint.Comment(commentHint) where
import Hint.Type
import Data.Char
import Data.List.Extra
import Refact.Types(Refactoring(ModifyComment))
pragmas = words $
"LANGUAGE OPTIONS_GHC INCLUDE WARNING DEPRECATED MINIMAL INLINE NOINLINE INLINABLE " ++
"CONLIKE LINE SPECIALIZE SPECIALISE UNPACK NOUNPACK SOURCE"
commentHint :: Comment -> [Idea]
commentHint c@(Comment True span s)
| "#" `isSuffixOf` s && not ("#" `isPrefixOf` s) = [grab "Fix pragma markup" c $ '#':s]
| name `elem` pragmas = [grab "Use pragma syntax" c $ "# " ++ trim s ++ " #"]
where name = takeWhile (\x -> isAlphaNum x || x == '_') $ dropWhile isSpace s
commentHint _ = []
grab :: String -> Comment -> String -> Idea
grab msg (Comment typ pos s1) s2 = rawIdea Suggestion msg pos (f s1) (Just $ f s2) [] refact
where f s = if typ then "{-" ++ s ++ "-}" else "--" ++ s
refact = [ModifyComment (toRefactSrcSpan pos) (f s2)]
hlint-2.0.11/src/Hint/Bracket.hs 0000644 0000000 0000000 00000012654 13210071537 014506 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns #-}
{-
Raise an error if you are bracketing an atom, or are enclosed be a list bracket
-- expression bracket reduction
yes = (f x) x -- @Suggestion f x x
no = f (x x)
yes = (foo) -- foo
yes = (foo bar) -- @Suggestion foo bar
yes = foo (bar) -- @Warning bar
yes = foo ((x x)) -- @Suggestion (x x)
yes = (f x) ||| y -- @Suggestion f x ||| y
yes = if (f x) then y else z -- @Suggestion if f x then y else z
yes = if x then (f y) else z -- @Suggestion if x then f y else z
yes = (a foo) :: Int -- @Suggestion a foo :: Int
yes = [(foo bar)] -- @Suggestion [foo bar]
yes = foo ((x y), z) -- @Suggestion (x y, z)
yes = C { f = (e h) } -- @Suggestion C {f = e h}
yes = \ x -> (x && x) -- @Suggestion \x -> x && x
no = \(x -> y) -> z
yes = (`foo` (bar baz)) -- @Suggestion (`foo` bar baz)
yes = f ((x)) -- @Warning x
main = do f; (print x) -- @Suggestion do f print x
-- type bracket reduction
foo :: (Int -> Int) -> Int
foo :: (Maybe Int) -> a -- @Suggestion Maybe Int -> a
instance Named (DeclHead S)
data Foo = Foo {foo :: (Maybe Foo)} -- @Suggestion foo :: Maybe Foo
-- pattern bracket reduction
foo (x:xs) = 1
foo (True) = 1 -- @Warning True
foo ((True)) = 1 -- @Warning True
foo (A{}) = True -- A{}
f x = case x of (Nothing) -> 1; _ -> 2 -- Nothing
-- dollar reduction tests
no = groupFsts . sortFst $ mr
yes = split "to" $ names -- split "to" names
yes = white $ keysymbol -- white keysymbol
yes = operator foo $ operator -- operator foo operator
no = operator foo $ operator bar
yes = return $ Record{a=b} -- return Record{a=b}
-- $/bracket rotation tests
yes = (b $ c d) ++ e -- b (c d) ++ e
yes = (a b $ c d) ++ e -- a b (c d) ++ e
no = (f . g $ a) ++ e
no = quickCheck ((\h -> cySucc h == succ h) :: Hygiene -> Bool)
foo = (case x of y -> z; q -> w) :: Int
-- backup fixity resolution
main = do a += b . c; return $ a . b
-- annotations
main = 1; {-# ANN module ("HLint: ignore Use camelCase" :: String) #-}
main = 1; {-# ANN module (1 + (2)) #-} -- 2
-- special cases (from esqueleto, see #224)
main = operate <$> (select $ from $ \user -> return $ user ^. UserEmail)
-}
module Hint.Bracket(bracketHint) where
import Hint.Type
import Data.Data
import Refact.Types
bracketHint :: DeclHint
bracketHint _ _ x =
concatMap (\x -> bracket True x ++ dollar x) (childrenBi (descendBi annotations x) :: [Exp_]) ++
concatMap (bracket False) (childrenBi x :: [Type_]) ++
concatMap (bracket False) (childrenBi x :: [Pat_]) ++
concatMap fieldDecl (childrenBi x)
where
-- Brackets at the roots of annotations are fine, so we strip them
annotations :: Annotation S -> Annotation S
annotations = descendBi $ \x -> case (x :: Exp_) of
Paren _ x -> x
x -> x
-- Dirty, should add to Brackets type class I think
tyConToRtype :: String -> RType
tyConToRtype "Exp" = Expr
tyConToRtype "Type" = Type
tyConToRtype "Pat" = Pattern
tyConToRtype _ = Expr
findType :: (Data a) => a -> RType
findType = tyConToRtype . dataTypeName . dataTypeOf
-- Just if at least one paren was removed
-- Nothing if zero parens were removed
remParens :: Brackets a => a -> Maybe a
remParens = fmap go . remParen
where
go e = maybe e go (remParen e)
bracket :: (Data (a S), ExactP a, Pretty (a S), Brackets (a S)) => Bool -> a S -> [Idea]
bracket bad = f Nothing
where
msg = "Redundant bracket"
-- f (Maybe (index, parent, gen)) child
f :: (Data (a S), ExactP a, Pretty (a S), Brackets (a S)) => Maybe (Int,a S,a S -> a S) -> a S -> [Idea]
f Just{} o@(remParens -> Just x) | isAtom x = bracketError msg o x : g x
f Nothing o@(remParens -> Just x) | bad || isAtom x = (if isAtom x then bracketError else bracketWarning) msg o x : g x
f (Just (i,o,gen)) v@(remParens -> Just x) | not $ needBracket i o x =
suggest msg o (gen x) [r] : g x
where
typ = findType v
r = Replace typ (toSS v) [("x", toSS x)] "x"
f _ x = g x
g :: (Data (a S), ExactP a, Pretty (a S), Brackets (a S)) => a S -> [Idea]
g o = concat [f (Just (i,o,gen)) x | (i,(x,gen)) <- zip [0..] $ holes o]
bracketWarning msg o x =
suggest msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"]
bracketError msg o x =
warn msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"]
fieldDecl :: FieldDecl S -> [Idea]
fieldDecl o@(FieldDecl a b v@(TyParen _ c))
= [suggest "Redundant bracket" o (FieldDecl a b c) [Replace Type (toSS v) [("x", toSS c)] "x"]]
fieldDecl _ = []
dollar :: Exp_ -> [Idea]
dollar = concatMap f . universe
where
f x = [suggest "Redundant $" x y [r] | InfixApp _ a d b <- [x], opExp d ~= "$"
,let y = App an a b, not $ needBracket 0 y a, not $ needBracket 1 y b
,let r = Replace Expr (toSS x) [("a", toSS a), ("b", toSS b)] "a b"
]
++
[suggest "Move brackets to avoid $" x (t y) [r] |(t, e@(Paren _ (InfixApp _ a1 op1 a2))) <- splitInfix x
,opExp op1 ~= "$", isVar a1 || isApp a1 || isParen a1, not $ isAtom a2
,not $ a1 ~= "select" -- special case for esqueleto, see #224
, let y = App an a1 (Paren an a2)
, let r = Replace Expr (toSS e) [("a", toSS a1), ("b", toSS a2)] "a (b)" ]
-- return both sides, and a way to put them together again
splitInfix :: Exp_ -> [(Exp_ -> Exp_, Exp_)]
splitInfix (InfixApp s a b c) = [(InfixApp s a b, c), (\a -> InfixApp s a b c, a)]
splitInfix _ = []
hlint-2.0.11/src/Hint/All.hs 0000644 0000000 0000000 00000004564 13210071537 013644 0 ustar 00 0000000 0000000
module Hint.All(
Hint(..), HintBuiltin(..), DeclHint, ModuHint,
resolveHints, hintRules, builtinHints
) where
import Data.Monoid
import Config.Type
import Data.Either
import Data.List
import Hint.Type
import Prelude
import Hint.Match
import Hint.List
import Hint.ListRec
import Hint.Monad
import Hint.Lambda
import Hint.Bracket
import Hint.Naming
import Hint.Pattern
import Hint.Import
import Hint.Export
import Hint.Pragma
import Hint.Restrict
import Hint.Extensions
import Hint.Duplicate
import Hint.Comment
import Hint.Unsafe
import Hint.NewType
-- | A list of the builtin hints wired into HLint.
-- This list is likely to grow over time.
data HintBuiltin =
HintList | HintListRec | HintMonad | HintLambda |
HintBracket | HintNaming | HintPattern | HintImport | HintExport |
HintPragma | HintExtensions | HintUnsafe | HintDuplicate | HintRestrict |
HintComment | HintNewType
deriving (Show,Eq,Ord,Bounded,Enum)
builtin :: HintBuiltin -> Hint
builtin x = case x of
HintList -> decl listHint
HintListRec -> decl listRecHint
HintMonad -> decl monadHint
HintLambda -> decl lambdaHint
HintBracket -> decl bracketHint
HintNaming -> decl namingHint
HintPattern -> decl patternHint
HintImport -> modu importHint
HintExport -> modu exportHint
HintPragma -> modu pragmaHint
HintExtensions -> modu extensionsHint
HintUnsafe -> modu unsafeHint
HintDuplicate -> mods duplicateHint
HintComment -> comm commentHint
HintNewType -> decl newtypeHint
HintRestrict -> mempty{hintModule=restrictHint}
where
decl x = mempty{hintDecl=const x}
modu x = mempty{hintModule=const x}
mods x = mempty{hintModules=const x}
comm x = mempty{hintComment=const x}
-- | A list of builtin hints, currently including entries such as @\"List\"@ and @\"Bracket\"@.
builtinHints :: [(String, Hint)]
builtinHints = [(drop 4 $ show h, builtin h) | h <- [minBound .. maxBound]]
-- | Transform a list of 'HintBuiltin' or 'HintRule' into a 'Hint'.
resolveHints :: [Either HintBuiltin HintRule] -> Hint
resolveHints xs = mconcat $ mempty{hintDecl=const $ readMatch rights} : map builtin (nub lefts)
where (lefts,rights) = partitionEithers xs
-- | Transform a list of 'HintRule' into a 'Hint'.
hintRules :: [HintRule] -> Hint
hintRules = resolveHints . map Right
hlint-2.0.11/src/Config/ 0000755 0000000 0000000 00000000000 13210071537 013072 5 ustar 00 0000000 0000000 hlint-2.0.11/src/Config/Yaml.hs 0000644 0000000 0000000 00000026243 13210071537 014337 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings, ViewPatterns, RecordWildCards, GeneralizedNewtypeDeriving, TupleSections #-}
module Config.Yaml(
ConfigYaml,
readFileConfigYaml,
settingsFromConfigYaml
) where
import Config.Type
import Data.Yaml
import Data.Either
import Data.Maybe
import Data.List.Extra
import Data.Tuple.Extra
import Control.Monad.Extra
import Control.Exception.Extra
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Data.ByteString.Char8 as BS
import qualified Data.HashMap.Strict as Map
import HSE.All hiding (Rule, String)
import Data.Functor
import Data.Monoid
import Util
import Prelude
-- | Read a config file in YAML format. Takes a filename, and optionally the contents.
-- Fails if the YAML doesn't parse or isn't valid HLint YAML
readFileConfigYaml :: FilePath -> Maybe String -> IO ConfigYaml
readFileConfigYaml file contents = do
val <- case contents of
Nothing -> decodeFileEither file
Just src -> return $ decodeEither' $ BS.pack src
case val of
Left e -> fail $ "Failed to read YAML configuration file " ++ file ++ "\n " ++ displayException e
Right v -> return v
---------------------------------------------------------------------
-- YAML DATA TYPE
newtype ConfigYaml = ConfigYaml [ConfigItem] deriving (Monoid,Show)
data ConfigItem
= ConfigPackage Package
| ConfigGroup Group
| ConfigSetting [Setting]
deriving Show
data Package = Package
{packageName :: String
,packageModules :: [ImportDecl S]
} deriving Show
data Group = Group
{groupName :: String
,groupEnabled :: Bool
,groupImports :: [Either String (ImportDecl S)] -- Left for package imports
,groupRules :: [Either HintRule Classify] -- HintRule has scope set to mempty
} deriving Show
---------------------------------------------------------------------
-- YAML PARSING LIBRARY
data Val = Val
Value -- the actual value I'm focused on
[(String, Value)] -- the path of values I followed (for error messages)
newVal :: Value -> Val
newVal x = Val x [("root", x)]
getVal :: Val -> Value
getVal (Val x _) = x
addVal :: String -> Value -> Val -> Val
addVal key v (Val focus path) = Val v $ (key,v) : path
-- | Failed when parsing some value, give an informative error message.
parseFail :: Val -> String -> Parser a
parseFail (Val focus path) msg = fail $
"Error when decoding YAML, " ++ msg ++ "\n" ++
"Along path: " ++ unwords steps ++ "\n" ++
"When at: " ++ fst (word1 $ show focus) ++ "\n" ++
-- aim to show a smallish but relevant context
dotDot (fromMaybe (encode focus) $ listToMaybe $ dropWhile (\x -> BS.length x > 250) $ map encode contexts)
where
(steps, contexts) = unzip $ reverse path
dotDot x = let (a,b) = BS.splitAt 250 x in BS.unpack a ++ (if BS.null b then "" else "...")
parseArray :: Val -> Parser [Val]
parseArray v@(getVal -> Array xs) = concatMapM parseArray $ zipWith (\i x -> addVal (show i) x v) [0..] $ V.toList xs
parseArray v = return [v]
parseObject :: Val -> Parser (Map.HashMap T.Text Value)
parseObject (getVal -> Object x) = return x
parseObject v = parseFail v "Expected an Object"
parseObject1 :: Val -> Parser (String, Val)
parseObject1 v = do
mp <- parseObject v
case Map.keys mp of
[T.unpack -> s] -> (s,) <$> parseField s v
_ -> parseFail v $ "Expected exactly one key but got " ++ show (Map.size mp)
parseString :: Val -> Parser String
parseString (getVal -> String x) = return $ T.unpack x
parseString v = parseFail v "Expected a String"
parseArrayString :: Val -> Parser [String]
parseArrayString = parseArray >=> mapM parseString
parseBool :: Val -> Parser Bool
parseBool (getVal -> Bool b) = return b
parseBool v = parseFail v "Expected a Bool"
parseField :: String -> Val -> Parser Val
parseField s v = do
x <- parseFieldOpt s v
case x of
Nothing -> parseFail v $ "Expected a field named " ++ s
Just v -> return v
parseFieldOpt :: String -> Val -> Parser (Maybe Val)
parseFieldOpt s v = do
mp <- parseObject v
case Map.lookup (T.pack s) mp of
Nothing -> return Nothing
Just x -> return $ Just $ addVal s x v
allowFields :: Val -> [String] -> Parser ()
allowFields v allow = do
mp <- parseObject v
let bad = map T.unpack (Map.keys mp) \\ allow
when (bad /= []) $
parseFail v $ "Not allowed keys: " ++ unwords bad
parseHSE :: (ParseMode -> String -> ParseResult v) -> Val -> Parser v
parseHSE parser v = do
x <- parseString v
case parser defaultParseMode{extensions=defaultExtensions} x of
ParseOk x -> return x
ParseFailed loc s -> parseFail v $ "Failed to parse " ++ s ++ ", when parsing:\n " ++ x
---------------------------------------------------------------------
-- YAML TO DATA TYPE
instance FromJSON ConfigYaml where
parseJSON Null = return mempty
parseJSON x = parseConfigYaml $ newVal x
parseConfigYaml :: Val -> Parser ConfigYaml
parseConfigYaml v = do
vs <- parseArray v
fmap ConfigYaml $ forM vs $ \o@v -> do
(s, v) <- parseObject1 v
case s of
"package" -> ConfigPackage <$> parsePackage v
"group" -> ConfigGroup <$> parseGroup v
"arguments" -> ConfigSetting . map SettingArgument <$> parseArrayString v
"fixity" -> ConfigSetting <$> parseFixity v
_ | isJust $ getSeverity s -> ConfigGroup . ruleToGroup <$> parseRule o
_ | Just r <- getRestrictType s -> ConfigSetting . map SettingRestrict <$> (parseArray v >>= mapM (parseRestrict r))
_ -> parseFail v "Expecting an object with a 'package' or 'group' key, a hint or a restriction"
parsePackage :: Val -> Parser Package
parsePackage v = do
packageName <- parseField "name" v >>= parseString
packageModules <- parseField "modules" v >>= parseArray >>= mapM (parseHSE parseImportDeclWithMode)
allowFields v ["name","modules"]
return Package{..}
parseFixity :: Val -> Parser [Setting]
parseFixity v = parseArray v >>= concatMapM (parseHSE parseDeclWithMode >=> f)
where
f x@InfixDecl{} = return $ map Infix $ getFixity x
f _ = parseFail v "Expected fixity declaration"
parseGroup :: Val -> Parser Group
parseGroup v = do
groupName <- parseField "name" v >>= parseString
groupEnabled <- parseFieldOpt "enabled" v >>= maybe (return True) parseBool
groupImports <- parseFieldOpt "imports" v >>= maybe (return []) (parseArray >=> mapM parseImport)
groupRules <- parseFieldOpt "rules" v >>= maybe (return []) parseArray >>= concatMapM parseRule
allowFields v ["name","enabled","imports","rules"]
return Group{..}
where
parseImport v = do
x <- parseString v
case word1 x of
("package", x) -> return $ Left x
_ -> Right <$> parseHSE parseImportDeclWithMode v
ruleToGroup :: [Either HintRule Classify] -> Group
ruleToGroup = Group "" True []
parseRule :: Val -> Parser [Either HintRule Classify]
parseRule v = do
(severity, v) <- parseSeverityKey v
isRule <- isJust <$> parseFieldOpt "lhs" v
if isRule then do
hintRuleLHS <- parseField "lhs" v >>= parseHSE parseExpWithMode
hintRuleRHS <- parseField "rhs" v >>= parseHSE parseExpWithMode
hintRuleNotes <- parseFieldOpt "note" v >>= maybe (return []) (fmap (map asNote) . parseArrayString)
hintRuleName <- parseFieldOpt "name" v >>= maybe (return $ guessName hintRuleLHS hintRuleRHS) parseString
hintRuleSide <- parseFieldOpt "side" v >>= maybe (return Nothing) (fmap Just . parseHSE parseExpWithMode)
allowFields v ["lhs","rhs","note","name","side"]
let hintRuleScope = mempty
return [Left HintRule{hintRuleSeverity=severity, ..}]
else do
names <- parseFieldOpt "name" v >>= maybe (return []) parseArrayString
within <- parseFieldOpt "within" v >>= maybe (return [("","")]) (parseArray >=> concatMapM parseWithin)
return [Right $ Classify severity n a b | (a,b) <- within, n <- ["" | null names] ++ names]
parseRestrict :: RestrictType -> Val -> Parser Restrict
parseRestrict restrictType v = do
def <- parseFieldOpt "default" v
case def of
Just def -> do
b <- parseBool def
allowFields v ["default"]
return $ Restrict restrictType b [] [] []
Nothing -> do
restrictName <- parseFieldOpt "name" v >>= maybe (return []) parseArrayString
restrictWithin <- parseFieldOpt "within" v >>= maybe (return [("","")]) (parseArray >=> concatMapM parseWithin)
restrictAs <- parseFieldOpt "as" v >>= maybe (return []) parseArrayString
allowFields v $ ["as" | restrictType == RestrictModule] ++ ["name","within"]
return Restrict{restrictDefault=True,..}
parseWithin :: Val -> Parser [(String, String)] -- (module, decl)
parseWithin v = do
x <- parseHSE parseExpWithMode v
case x of
Var _ (UnQual _ name) -> return [("",fromNamed name)]
Var _ (Qual _ (ModuleName _ mod) name) -> return [(mod, fromNamed name)]
Con _ (UnQual _ name) -> return [(fromNamed name,""),("",fromNamed name)]
Con _ (Qual _ (ModuleName _ mod) name) -> return [(mod ++ "." ++ fromNamed name,""),(mod,fromNamed name)]
_ -> parseFail v "Bad classification rule"
parseSeverityKey :: Val -> Parser (Severity, Val)
parseSeverityKey v = do
(s, v) <- parseObject1 v
case getSeverity s of
Just sev -> return (sev, v)
_ -> parseFail v $ "Key should be a severity (e.g. warn/error/suggest) but got " ++ s
guessName :: Exp_ -> Exp_ -> String
guessName lhs rhs
| n:_ <- rs \\ ls = "Use " ++ n
| n:_ <- ls \\ rs = "Redundant " ++ n
| otherwise = defaultHintName
where
(ls, rs) = both f (lhs, rhs)
f = filter (not . isUnifyVar) . map (\x -> fromNamed (x :: Name S)) . childrenS
asNote :: String -> Note
asNote "IncreasesLaziness" = IncreasesLaziness
asNote "DecreasesLaziness" = DecreasesLaziness
asNote (word1 -> ("RemovesError",x)) = RemovesError x
asNote (word1 -> ("ValidInstance",x)) = uncurry ValidInstance $ word1 x
asNote x = Note x
---------------------------------------------------------------------
-- SETTINGS
settingsFromConfigYaml :: [ConfigYaml] -> [Setting]
settingsFromConfigYaml (mconcat -> ConfigYaml configs) = settings ++ concatMap f groups
where
packages = [x | ConfigPackage x <- configs]
groups = [x | ConfigGroup x <- configs]
settings = concat [x | ConfigSetting x <- configs]
packageMap = Map.fromListWith (++) [(packageName, packageModules) | Package{..} <- packages]
groupMap = Map.fromListWith (\new old -> new) [(groupName, groupEnabled) | Group{..} <- groups]
f Group{..}
| Map.lookup groupName groupMap == Just False = []
| otherwise = map (either (\r -> SettingMatchExp r{hintRuleScope=scope}) SettingClassify) groupRules
where scope = asScope packageMap groupImports
asScope :: Map.HashMap String [ImportDecl S] -> [Either String (ImportDecl S)] -> Scope
asScope packages xs = scopeCreate $ Module an Nothing [] (concatMap f xs) []
where
f (Right x) = [x]
f (Left x) | Just pkg <- Map.lookup x packages = pkg
| otherwise = error $ "asScope failed to do lookup, " ++ x
hlint-2.0.11/src/Config/Type.hs 0000644 0000000 0000000 00000010775 13210071537 014361 0 ustar 00 0000000 0000000
module Config.Type(
Severity(..), Classify(..), HintRule(..), Note(..), Setting(..),
Restrict(..), RestrictType(..),
defaultHintName, isUnifyVar, showNotes, getSeverity, getRestrictType
) where
import HSE.All
import Data.Char
import Data.List.Extra
import Prelude
getSeverity :: String -> Maybe Severity
getSeverity "ignore" = Just Ignore
getSeverity "warn" = Just Warning
getSeverity "warning" = Just Warning
getSeverity "suggest" = Just Suggestion
getSeverity "suggestion" = Just Suggestion
getSeverity "error" = Just Error
getSeverity "hint" = Just Suggestion
getSeverity _ = Nothing
getRestrictType :: String -> Maybe RestrictType
getRestrictType "modules" = Just RestrictModule
getRestrictType "extensions" = Just RestrictExtension
getRestrictType "flags" = Just RestrictFlag
getRestrictType "functions" = Just RestrictFunction
getRestrictType _ = Nothing
defaultHintName :: String
defaultHintName = "Use alternative"
-- | How severe an issue is.
data Severity
= Ignore -- ^ The issue has been explicitly ignored and will usually be hidden (pass @--show@ on the command line to see ignored ideas).
| Suggestion -- ^ Suggestions are things that some people may consider improvements, but some may not.
| Warning -- ^ Warnings are suggestions that are nearly always a good idea to apply.
| Error -- ^ Available as a setting for the user.
deriving (Eq,Ord,Show,Read,Bounded,Enum)
-- Any 1-letter variable names are assumed to be unification variables
isUnifyVar :: String -> Bool
isUnifyVar [x] = x == '?' || isAlpha x
isUnifyVar _ = False
---------------------------------------------------------------------
-- TYPE
-- | A note describing the impact of the replacement.
data Note
= IncreasesLaziness -- ^ The replacement is increases laziness, for example replacing @reverse (reverse x)@ with @x@ makes the code lazier.
| DecreasesLaziness -- ^ The replacement is decreases laziness, for example replacing @(fst x, snd x)@ with @x@ makes the code stricter.
| RemovesError String -- ^ The replacement removes errors, for example replacing @foldr1 (+)@ with @sum@ removes an error on @[]@, and might contain the text @\"on []\"@.
| ValidInstance String String -- ^ The replacement assumes standard type class lemmas, a hint with the note @ValidInstance \"Eq\" \"x\"@ might only be valid if
-- the @x@ variable has a reflexive @Eq@ instance.
| Note String -- ^ An arbitrary note.
deriving (Eq,Ord)
instance Show Note where
show IncreasesLaziness = "increases laziness"
show DecreasesLaziness = "decreases laziness"
show (RemovesError x) = "removes error " ++ x
show (ValidInstance x y) = "requires a valid `" ++ x ++ "` instance for `" ++ y ++ "`"
show (Note x) = x
showNotes :: [Note] -> String
showNotes = intercalate ", " . map show . filter use
where use ValidInstance{} = False -- Not important enough to tell an end user
use _ = True
-- | How to classify an 'Idea'. If any matching field is @\"\"@ then it matches everything.
data Classify = Classify
{classifySeverity :: Severity -- ^ Severity to set the 'Idea' to.
,classifyHint :: String -- ^ Match on 'Idea' field 'ideaHint'.
,classifyModule :: String -- ^ Match on 'Idea' field 'ideaModule'.
,classifyDecl :: String -- ^ Match on 'Idea' field 'ideaDecl'.
}
deriving Show
-- | A @LHS ==> RHS@ style hint rule.
data HintRule {- PUBLIC -} = HintRule
{hintRuleSeverity :: Severity -- ^ Default severity for the hint.
,hintRuleName :: String -- ^ Name for the hint.
,hintRuleScope :: Scope -- ^ Module scope in which the hint operates.
,hintRuleLHS :: Exp SrcSpanInfo -- ^ LHS
,hintRuleRHS :: Exp SrcSpanInfo -- ^ RHS
,hintRuleSide :: Maybe (Exp SrcSpanInfo) -- ^ Side condition, typically specified with @where _ = ...@.
,hintRuleNotes :: [Note] -- ^ Notes about application of the hint.
}
deriving Show
data RestrictType = RestrictModule | RestrictExtension | RestrictFlag | RestrictFunction deriving (Show,Eq,Ord)
data Restrict = Restrict
{restrictType :: RestrictType
,restrictDefault :: Bool
,restrictName :: [String]
,restrictAs :: [String] -- for RestrictModule only, what you can import it as
,restrictWithin :: [(String, String)]
} deriving Show
data Setting
= SettingClassify Classify
| SettingMatchExp HintRule
| SettingRestrict Restrict
| SettingArgument String -- ^ Extra command-line argument
| Builtin String -- use a builtin hint set
| Infix Fixity
deriving Show
hlint-2.0.11/src/Config/Read.hs 0000644 0000000 0000000 00000001027 13210071537 014301 0 ustar 00 0000000 0000000
module Config.Read(readFilesConfig) where
import Config.Type
import Config.Haskell
import Config.Yaml
import Data.List.Extra
import System.FilePath
readFilesConfig :: [(FilePath, Maybe String)] -> IO [Setting]
readFilesConfig files = do
yaml <- mapM (uncurry readFileConfigYaml) yaml
haskell <- mapM (uncurry readFileConfigHaskell) haskell
return $ concat haskell ++ settingsFromConfigYaml yaml
where
(yaml, haskell) = partition (\(x,_) -> lower (takeExtension x) `elem` [".yml",".yaml"]) files
hlint-2.0.11/src/Config/Haskell.hs 0000644 0000000 0000000 00000012676 13210071537 015025 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, ViewPatterns #-}
module Config.Haskell(
readPragma,
readSetting,
readFileConfigHaskell
) where
import HSE.All
import Data.Char
import Data.List.Extra
import Config.Type
import Util
import Prelude
addInfix = parseFlagsAddFixities $ infix_ (-1) ["==>"]
---------------------------------------------------------------------
-- READ A SETTINGS FILE
readFileConfigHaskell :: FilePath -> Maybe String -> IO [Setting]
readFileConfigHaskell file contents = do
let flags = addInfix defaultParseFlags
res <- parseModuleEx flags file contents
case res of
Left (ParseError sl msg err) ->
error $ "Config parse failure at " ++ showSrcLoc sl ++ ": " ++ msg ++ "\n" ++ err
Right (m, _) -> return $ readSettings m
-- | Given a module containing HLint settings information return the 'Classify' rules and the 'HintRule' expressions.
-- Any fixity declarations will be discarded, but any other unrecognised elements will result in an exception.
readSettings :: Module_ -> [Setting]
readSettings m = concatMap (readSetting $ scopeCreate m) $ concatMap getEquations $
[AnnPragma l x | AnnModulePragma l x <- modulePragmas m] ++ moduleDecls m
readSetting :: Scope -> Decl_ -> [Setting]
readSetting s (FunBind _ [Match _ (Ident _ (getSeverity -> Just severity)) pats (UnGuardedRhs _ bod) bind])
| InfixApp _ lhs op rhs <- bod, opExp op ~= "==>" =
let (a,b) = readSide $ childrenBi bind in
[SettingMatchExp $ HintRule severity (head $ snoc names defaultHintName) s (fromParen lhs) (fromParen rhs) a b]
| otherwise = [SettingClassify $ Classify severity n a b | n <- names2, (a,b) <- readFuncs bod]
where
names = filter (not . null) $ getNames pats bod
names2 = ["" | null names] ++ names
readSetting s x | "test" `isPrefixOf` map toLower (fromNamed x) = []
readSetting s (AnnPragma _ x) | Just y <- readPragma x = [SettingClassify y]
readSetting s (PatBind an (PVar _ name) bod bind) = readSetting s $ FunBind an [Match an name [] bod bind]
readSetting s (FunBind an xs) | length xs /= 1 = concatMap (readSetting s . FunBind an . return) xs
readSetting s (SpliceDecl an (App _ (Var _ x) (Lit _ y))) = readSetting s $ FunBind an [Match an (toNamed $ fromNamed x) [PLit an (Signless an) y] (UnGuardedRhs an $ Lit an $ String an "" "") Nothing]
readSetting s x@InfixDecl{} = map Infix $ getFixity x
readSetting s x = errorOn x "bad hint"
-- | Read an {-# ANN #-} pragma and determine if it is intended for HLint.
-- Return Nothing if it is not an HLint pragma, otherwise what it means.
readPragma :: Annotation S -> Maybe Classify
readPragma o = case o of
Ann _ name x -> f (fromNamed name) x
TypeAnn _ name x -> f (fromNamed name) x
ModuleAnn _ x -> f "" x
where
f name (Lit _ (String _ s _)) | "hlint:" `isPrefixOf` map toLower s =
case getSeverity a of
Nothing -> errorOn o "bad classify pragma"
Just severity -> Just $ Classify severity (trimStart b) "" name
where (a,b) = break isSpace $ trimStart $ drop 6 s
f name (Paren _ x) = f name x
f name (ExpTypeSig _ x _) = f name x
f _ _ = Nothing
readSide :: [Decl_] -> (Maybe Exp_, [Note])
readSide = foldl f (Nothing,[])
where f (Nothing,notes) (PatBind _ PWildCard{} (UnGuardedRhs _ side) Nothing) = (Just side, notes)
f (Nothing,notes) (PatBind _ (fromNamed -> "side") (UnGuardedRhs _ side) Nothing) = (Just side, notes)
f (side,[]) (PatBind _ (fromNamed -> "note") (UnGuardedRhs _ note) Nothing) = (side,g note)
f _ x = errorOn x "bad side condition"
g (Lit _ (String _ x _)) = [Note x]
g (List _ xs) = concatMap g xs
g x = case fromApps x of
[con -> Just "IncreasesLaziness"] -> [IncreasesLaziness]
[con -> Just "DecreasesLaziness"] -> [DecreasesLaziness]
[con -> Just "RemovesError",fromString -> Just a] -> [RemovesError a]
[con -> Just "ValidInstance",fromString -> Just a,var -> Just b] -> [ValidInstance a b]
_ -> errorOn x "bad note"
con :: Exp_ -> Maybe String
con c@Con{} = Just $ prettyPrint c; con _ = Nothing
var c@Var{} = Just $ prettyPrint c; var _ = Nothing
-- Note: Foo may be ("","Foo") or ("Foo",""), return both
readFuncs :: Exp_ -> [(String, String)]
readFuncs (App _ x y) = readFuncs x ++ readFuncs y
readFuncs (Lit _ (String _ "" _)) = [("","")]
readFuncs (Var _ (UnQual _ name)) = [("",fromNamed name)]
readFuncs (Var _ (Qual _ (ModuleName _ mod) name)) = [(mod, fromNamed name)]
readFuncs (Con _ (UnQual _ name)) = [(fromNamed name,""),("",fromNamed name)]
readFuncs (Con _ (Qual _ (ModuleName _ mod) name)) = [(mod ++ "." ++ fromNamed name,""),(mod,fromNamed name)]
readFuncs x = errorOn x "bad classification rule"
getNames :: [Pat_] -> Exp_ -> [String]
getNames ps _ | ps /= [], Just ps <- mapM fromPString ps = ps
getNames [] (InfixApp _ lhs op rhs) | opExp op ~= "==>" = map ("Use "++) names
where
lnames = map f $ childrenS lhs
rnames = map f $ childrenS rhs
names = filter (not . isUnifyVar) $ (rnames \\ lnames) ++ rnames
f (Ident _ x) = x
f (Symbol _ x) = x
getNames _ _ = []
errorOn :: (Annotated ast, Pretty (ast S)) => ast S -> String -> b
errorOn val msg = exitMessageImpure $
showSrcLoc (getPointLoc $ ann val) ++
": Error while reading hint file, " ++ msg ++ "\n" ++
prettyPrint val
hlint-2.0.11/src/Config/Compute.hs 0000644 0000000 0000000 00000005405 13210071537 015046 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards #-}
-- | Given a file, guess settings from it by looking at the hints.
module Config.Compute(computeSettings) where
import HSE.All
import Config.Type
import Config.Haskell
import Data.Monoid
import Prelude
-- | Given a source file, guess some hints that might apply.
-- Returns the text of the hints (if you want to save it down) along with the settings to be used.
computeSettings :: ParseFlags -> FilePath -> IO (String, [Setting])
computeSettings flags file = do
x <- parseModuleEx flags file Nothing
case x of
Left (ParseError sl msg _) ->
return ("# Parse error " ++ showSrcLoc sl ++ ": " ++ msg, [])
Right (m, _) -> do
let xs = concatMap (findSetting $ UnQual an) (moduleDecls m)
r = concatMap (readSetting mempty) xs
s = unlines $ ["# hints found in " ++ file] ++ concatMap renderSetting r ++ ["# no hints found" | null xs]
return (s,r)
renderSetting :: Setting -> [String]
renderSetting (SettingMatchExp HintRule{..}) =
["- warn: {lhs: " ++ show (prettyPrint hintRuleLHS) ++ ", rhs: " ++ show (prettyPrint hintRuleRHS) ++ "}"]
renderSetting (Infix x) = ["- infix: " ++ show (prettyPrint (toInfixDecl x))]
renderSetting _ = []
findSetting :: (Name S -> QName S) -> Decl_ -> [Decl_]
findSetting qual (InstDecl _ _ _ (Just xs)) = concatMap (findSetting qual) [x | InsDecl _ x <- xs]
findSetting qual (PatBind _ (PVar _ name) (UnGuardedRhs _ bod) Nothing) = findExp (qual name) [] bod
findSetting qual (FunBind _ [InfixMatch _ p1 name ps rhs bind]) = findSetting qual $ FunBind an [Match an name (p1:ps) rhs bind]
findSetting qual (FunBind _ [Match _ name ps (UnGuardedRhs _ bod) Nothing]) = findExp (qual name) [] $ Lambda an ps bod
findSetting _ x@InfixDecl{} = [x]
findSetting _ _ = []
-- given a result function name, a list of variables, a body expression, give some hints
findExp :: QName S -> [String] -> Exp_ -> [Decl_]
findExp name vs (Lambda _ ps bod) | length ps2 == length ps = findExp name (vs++ps2) bod
| otherwise = []
where ps2 = [x | PVar_ x <- map view ps]
findExp name vs Var{} = []
findExp name vs (InfixApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $ App an x $ Paren an $ App an y (toNamed "_hlint")
findExp name vs bod = [PatBind an (toNamed "warn") (UnGuardedRhs an $ InfixApp an lhs (toNamed "==>") rhs) Nothing]
where
lhs = g $ transform f bod
rhs = apps $ Var an name : map snd rep
rep = zip vs $ map (toNamed . return) ['a'..]
f xx | Var_ x <- view xx, Just y <- lookup x rep = y
f (InfixApp _ x dol y) | isDol dol = App an x (paren y)
f x = x
g o@(InfixApp _ _ _ x) | isAnyApp x || isAtom x = o
g o@App{} = o
g o = paren o
hlint-2.0.11/data/ 0000755 0000000 0000000 00000000000 13210071537 012007 5 ustar 00 0000000 0000000 hlint-2.0.11/data/Test.hs 0000644 0000000 0000000 00000005543 13210071537 013271 0 ustar 00 0000000 0000000 -- These hints are for test purposes, and are not intended to
-- be used for real.
-- FIXME: Should make this module modules in one file, so can easily test lots of
-- things without them overlapping
module HLint.Test where
error = Prelude.readFile ==> bad
error = (x :: Int) ==> (x :: Int32)
where _ = noTypeCheck
error "Test1" = scanr ==> scanr
error "Test2" = filter ==> filter
error "Test3" = foldr ==> foldr
error "Test4" = foldl ==> foldl
ignore "Test1" = ""
ignore "Test3"
ignore "Test2" = ignoreTest
warn = ignoreTest3
suggest = ignoreTest4
ignore = Ignore_Test
{-# ANN module "HLint: ignore Test4" #-}
{-# ANN annTest2 "HLint: error" #-}
{-# ANN annTest3 ("HLint: warn" :: String) #-}
{-# ANN annTest4 ("HLint: suggest" :: String) #-}
{-# ANN type Ann_Test ("HLint: ignore") #-}
error = concat (map f x) ==> Data.List.concatMap f x
infix 9 +
error = a * (b+c) ==> undefined
error = Array.head ==> head
error = tail ==> Array.tail
warn = id Control.Arrow.*** id ==> id
error = zip [1..length x] x ==> zipFrom 1 x
error = before a ==> after a
{-
main = readFile "foo" >>= putStr \
-- bad
import Prelude hiding(readFile) \
import Data.ByteString.Char8(readFile) \
test = readFile "foo" >>= putStr
import Prelude as Prelude2 \
yes = Prelude2.readFile "foo" >>= putStr \
-- bad
yes = 32 :: Int -- 32 :: Int32
yes = before 12 -- after 12
ignoreTest = filter -- @Ignore ???
ignoreTest2 = filter -- @Error ???
ignoreTest3 = filter -- @Warning ???
ignoreTest4 = filter -- @Suggestion ???
ignoreAny = scanr -- @Ignore ???
ignoreNew = foldr -- @Ignore ???
type Ignore_Test = Int -- @Ignore ???
annTest = foldl -- @Ignore ???
annTest2 = foldl -- @Error ???
annTest3 = scanr -- @Warning ???
annTest4 = scanr -- @Suggestion ???
type Ann_Test = Int -- @Ignore ???
concatMap f x = concat (map f x)
concatMop f x = concat (map f x) -- Data.List.concatMap f x
yes = 1 * 2+3 -- undefined
import Foo; test = Foo.id 1
test = head
import Array; test = Array.head -- head
test = Array.head -- head
test = head
import qualified Array; test = head
import Array(tail); test = head
import Array(head); test = head -- head
import Array as A; test = A.head -- head
test = tail -- Array.tail
import qualified Array as B; test = tail -- B.tail
import Control.Arrow; test = id *** id -- id
test = id Control.Arrow.*** id -- id
import Control.Arrow as Q; test = id Q.*** id -- id
zip [1..length x]
zip [1..length x] x -- zipFrom 1 x
{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} \
{-# LANGUAGE RecordWildCards #-} -- @Ignore ???
{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} \
{-# LANGUAGE RecordWildCards #-} -- @Ignore ???
{-# ANN lam "HLint: ignore Redundant lambda" #-} \
lam = \x -> x x x -- @Ignore ???
{-# ANN module "HLint: ignore Reduce duplication" #-} \
dup = do a; a; a; a; a; a -- @Ignore ???
-}
hlint-2.0.11/data/report_template.html 0000644 0000000 0000000 00000006567 13210071537 016121 0 ustar 00 0000000 0000000
HLint Report