hlint-1.9.35/0000755000000000000000000000000012726504430011120 5ustar0000000000000000hlint-1.9.35/Setup.hs0000644000000000000000000000005612726504430012555 0ustar0000000000000000import Distribution.Simple main = defaultMain hlint-1.9.35/README.md0000644000000000000000000004260612726504430012407 0ustar0000000000000000# HLint [![Hackage version](https://img.shields.io/hackage/v/hlint.svg?label=Hackage)](https://hackage.haskell.org/package/hlint) [![Stackage version](https://www.stackage.org/package/hlint/badge/lts?label=Stackage)](https://www.stackage.org/package/hlint) [![Linux Build Status](https://img.shields.io/travis/ndmitchell/hlint.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/hlint) [![Windows Build Status](https://img.shields.io/appveyor/ci/ndmitchell/hlint.svg?label=Windows%20build)](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) ### 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 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. * Either the monomorphism restriction, or rank-2 types, may cause transformed programs to require type signatures to be manually inserted. * 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. ### 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 `-XHaskell98` selects Haskell 98 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 n processors append the flags `+RTS -Nn`, as described in the [GHC user manual](http://www.haskell.org/ghc/docs/latest/html/users_guide/runtime-control.html). HLint will usually perform fastest if n is equal to the number of physical processors. 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. ### Unicode support By default, HLint uses the current locale encoding. The encoding can be overridden with either `--utf8` or `--encoding=value`. For descriptions of some valid [encodings see the mkTextEncoding documentation](http://haskell.org/ghc/docs/latest/html/libraries/base/System-IO.html#v%3AmkTextEncoding). ## 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. ### How can I use `--with` or `--hint` with the default hints? HLint does not use the default set of hints if custom hints are specified on the command line using `--with` or `--hint`. To include the default hints either pass `--hint=HLint` on the command line, or add import `"hint" HLint.HLint` in one of the hint files you specify with `--hint`. ### 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. ## Customizing the hints Many of the hints that are applied by HLint are contained in Haskell source files which are installed in the data directory by Cabal. These files may be edited, to add library specific knowledge, to include hints that may have been missed, or to ignore unwanted hints. ### Choosing a package of hints By default, HLint will use the `HLint.hs` file either from the current working directory, or from the data directory. Alternatively, hint files can be specified with the `--hint` flag. HLint comes with a number of hint packages: * __Default__ - these are the hints that are used by default, covering most of the base libraries. * __Dollar__ - suggests the replacement `a $ b $ c` with `a . b $ c`. This hint is especially popular on the [\#haskell IRC channel](http://www.haskell.org/haskellwiki/IRC_channel). * __Generalise__ - suggests replacing specific variants of functions (i.e. `map`) with more generic functions (i.e. `fmap`). As an example, to check the file `Example.hs` with both the default hints and the dollar hint, I could type: `hlint Example.hs --hint=Default --hint=Dollar`. Alternatively, I could create the file `HLint.hs` in the working directory and give it the contents: import "hint" HLint.Default import "hint" HLint.Dollar ### 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). * `{-# 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. * `{-# ANN module "HLint: warn Use concatMap" #-}` - the hint to use `concatMap` is a warning. * `{-# ANN module "HLint: suggest Use concatMap" #-}` - the hint to use `concatMap` is a suggestion. Ignore directives can also be written in the hint files: * `ignore "Eta reduce"` - suppress all eta reduction suggestions. * `ignore "Eta reduce" = MyModule1 MyModule2` - suppress eta reduction hints in the `MyModule1` and `MyModule2` modules. * `ignore = MyModule.myFunction` - don't give any hints in the function `MyModule.myFunction`. * `error = MyModule.myFunction` - any hint in the function `MyModule.myFunction` is an error. * `error "Use concatMap"` - the hint to use `concatMap` is an error. * `warn "Use concatMap"` - the hint to use `concatMap` is a warning. * `suggest "Use concatMap"` - the hint to use `concatMap` is a suggestion. These directives are applied in the order they are given, with later hints overriding earlier ones. ### Adding hints The hint suggesting `concatMap` is defined as: warn = concat (map f x) ==> 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 hints file. 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 start 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 = null (intersect a b) ==> disjoint a b warn = dropWhile isSpace ==> trimStart 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. hlint-1.9.35/LICENSE0000644000000000000000000000276412726504430012136 0ustar0000000000000000Copyright Neil Mitchell 2006-2016. 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-1.9.35/hlint.cabal0000644000000000000000000000534012726504430013224 0ustar0000000000000000cabal-version: >= 1.8 build-type: Simple name: hlint version: 1.9.35 license: BSD3 license-file: LICENSE category: Development author: Neil Mitchell maintainer: Neil Mitchell copyright: Neil Mitchell 2006-2016 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: Default.hs Generalise.hs Dollar.hs HLint.hs 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.0.1, 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 description: Build with support for multithreaded execution flag gpl default: True description: Use GPL libraries, specifically hscolour library build-depends: base == 4.*, process, filepath, directory, containers, transformers, cpphs >= 1.20.1, cmdargs >= 0.10, haskell-src-exts >= 1.17 && < 1.18, uniplate >= 1.5, ansi-terminal >= 0.6.2, extra >= 1.4.9, refact >= 0.3 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.HLint2 Language.Haskell.HLint3 other-modules: Paths_hlint Apply CmdLine Grep HLint HsColour Idea Settings Report Util Parallel Refact HSE.All HSE.Bracket HSE.Evaluate HSE.FreeVars HSE.Match HSE.Scope HSE.Type HSE.Util Hint.All Hint.Bracket Hint.Comment Hint.Duplicate Hint.Extensions Hint.Import Hint.Lambda Hint.List Hint.ListRec Hint.Match Hint.Monad Hint.Naming Hint.Pattern Hint.Pragma Hint.Type Hint.Unsafe Hint.Util Test.All Test.Annotations Test.InputOutput Test.Proof Test.Translate Test.Util executable hlint build-depends: base, hlint main-is: src/Main.hs ghc-options: -rtsopts if flag(threaded) ghc-options: -threaded hlint-1.9.35/CHANGES.txt0000644000000000000000000005245112726504430012740 0ustar0000000000000000Changelog for HLint 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-1.9.35/src/0000755000000000000000000000000012726504430011707 5ustar0000000000000000hlint-1.9.35/src/Util.hs0000644000000000000000000001102312726504430013155 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification, Rank2Types, PatternGuards #-} module Util( defaultExtensions, Encoding, defaultEncoding, readFileEncoding', readEncoding, useEncoding, gzip, universeParentBi, descendIndex, exitMessage ) where import Control.Monad.Trans.State import Control.Exception import Data.Char import Data.List import System.Exit import System.IO.Extra hiding (readFileEncoding') import System.IO.Unsafe import Unsafe.Coerce import Data.Data import Data.Generics.Uniplate.Operations import Language.Haskell.Exts.Extension --------------------------------------------------------------------- -- SYSTEM.IO -- | An 'Encoding' represents how characters are stored in a file. Created with -- 'defaultEncoding' or 'readEncoding' and used with 'useEncoding'. type Encoding = TextEncoding -- | The system default encoding. defaultEncoding :: Encoding defaultEncoding = utf8 -- | Apply an encoding to a 'Handle'. useEncoding :: Handle -> Encoding -> IO () useEncoding = hSetEncoding readFileEncoding' :: Encoding -> FilePath -> IO String readFileEncoding' enc "-" = do useEncoding stdin enc getContents readFileEncoding' enc file = withFile file ReadMode $ \h -> do useEncoding h enc s <- hGetContents h evaluate $ length s return s -- | Create an encoding from a string, or throw an error if the encoding is not known. -- Accepts many encodings including @locale@, @utf-8@ and all those supported by the -- GHC @mkTextEncoding@ function. readEncoding :: String -> IO Encoding -- GHC's mkTextEncoding function is fairly poor - it doesn't support lots of fun things, -- so we fake them up, and then try mkTextEncoding last readEncoding "" = return defaultEncoding readEncoding enc | Just e <- lookup (f enc) [(f a, b) | (as,b) <- encs, a <- as] = return e | otherwise = do res <- try $ mkTextEncoding enc :: IO (Either SomeException TextEncoding) case res of Right e -> return e Left _ -> do let (a,b) = splitAt 2 $ map (head . fst) encs putStr $ unlines ["Error: Unknown text encoding argument, " ++ enc ,"Possible values:" ," " ++ unwords a ," " ++ unwords b ," and anything accepted by System.IO.mkTextEncoding"] exitWith $ ExitFailure 1 where f = map toLower . filter (`notElem` "-_ ") encs = let a*b = (words a, b) in ["ISO8859-1 8859-1 ISO8859 8859 LATIN LATIN1" * latin1 ,"LOCALE" * localeEncoding ,"UTF-8" * utf8 ,"UTF-8BOM" * utf8_bom ,"UTF-16" * utf16 ,"UTF-16LE" * utf16le ,"UTF-16BE" * utf16be ,"UTF-32" * utf16 ,"UTF-32LE" * utf16le ,"UTF-32BE" * utf16be] exitMessage :: String -> a exitMessage msg = unsafePerformIO $ do putStrLn msg exitWith $ ExitFailure 1 --------------------------------------------------------------------- -- 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) where op (Box x) (Box y) = f x (unsafeCoerce y) --------------------------------------------------------------------- -- DATA.GENERICS.UNIPLATE.OPERATIONS descendIndex :: Uniplate a => (Int -> a -> a) -> a -> a descendIndex f x = flip evalState 0 $ flip descendM x $ \y -> do i <- get modify (+1) return $ f i y 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 ] hlint-1.9.35/src/Settings.hs0000644000000000000000000003165512726504430014055 0ustar0000000000000000{-# LANGUAGE PatternGuards, ViewPatterns #-} module Settings( Severity(..), Classify(..), HintRule(..), Note(..), showNotes, Setting(..), defaultHintName, isUnifyVar, findSettings, readSettings, readSettings2, readPragma, findSettings2, addInfix ) where import Data.Monoid import HSE.All import Control.Monad.Extra import Data.Char import Data.Either import Data.List.Extra import System.FilePath import Util import Prelude 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) 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 -- Any 1-letter variable names are assumed to be unification variables isUnifyVar :: String -> Bool isUnifyVar [x] = x == '?' || isAlpha x isUnifyVar _ = False addInfix = parseFlagsAddFixities $ infix_ (-1) ["==>"] --------------------------------------------------------------------- -- 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 = 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 Setting = SettingClassify Classify | SettingMatchExp HintRule | Builtin String -- use a builtin hint set | Infix Fixity deriving Show --------------------------------------------------------------------- -- READ A SETTINGS FILE -- Given a list of hint files to start from -- Return the list of settings commands readSettings2 :: FilePath -> [FilePath] -> [String] -> IO [Setting] readSettings2 dataDir files hints = do (builtin,mods) <- fmap partitionEithers $ concatMapM (readHints dataDir) $ map Right files ++ map Left hints return $ map Builtin builtin ++ concatMap moduleSettings_ mods moduleSettings_ :: Module SrcSpanInfo -> [Setting] moduleSettings_ m = concatMap (readSetting $ scopeCreate m) $ concatMap getEquations $ [AnnPragma l x | AnnModulePragma l x <- modulePragmas m] ++ moduleDecls 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 SrcSpanInfo -> ([Classify], [HintRule]) readSettings m = ([x | SettingClassify x <- xs], [x | SettingMatchExp x <- xs]) where xs = moduleSettings_ m readHints :: FilePath -> Either String FilePath -> IO [Either String Module_] readHints datadir x = do (builtin,ms) <- case x of Left src -> findSettings datadir "CommandLine" (Just src) Right file -> findSettings datadir file Nothing return $ map Left builtin ++ map Right ms -- | Given the data directory (where the @hlint@ data files reside, see 'getHLintDataDir'), -- and a filename to read, and optionally that file's contents, produce a pair containing: -- -- 1. Builtin hints to use, e.g. @"List"@, which should be resolved using 'builtinHints'. -- -- 1. A list of modules containing hints, suitable for processing with 'readSettings'. -- -- Any parse failures will result in an exception. findSettings :: FilePath -> FilePath -> Maybe String -> IO ([String], [Module SrcSpanInfo]) findSettings dataDir file contents = do let flags = addInfix defaultParseFlags res <- parseModuleEx flags file contents case res of Left (ParseError sl msg err) -> exitMessage $ "Parse failure at " ++ showSrcLoc sl ++ ": " ++ msg ++ "\n" ++ err Right (m, _) -> do ys <- sequence [f $ fromNamed $ importModule i | i <- moduleImports m, importPkg i `elem` [Just "hint", Just "hlint"]] return $ concatUnzip $ ([],[m]) : ys where f x | Just x <- "HLint.Builtin." `stripPrefix` x = return ([x],[]) | Just x <- "HLint." `stripPrefix` x = findSettings dataDir (dataDir x <.> "hs") Nothing | otherwise = findSettings dataDir (x <.> "hs") Nothing 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" -- return Nothing if it is not an HLint pragma, otherwise all the settings 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 = exitMessage $ showSrcLoc (getPointLoc $ ann val) ++ ": Error while reading hint file, " ++ msg ++ "\n" ++ prettyPrint val --------------------------------------------------------------------- -- FIND SETTINGS IN A SOURCE FILE -- find definitions in a source file findSettings2 :: ParseFlags -> FilePath -> IO (String, [Setting]) findSettings2 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) s = unlines $ ["-- hints found in " ++ file] ++ map prettyPrint xs ++ ["-- no hints found" | null xs] r = concatMap (readSetting mempty) xs return (s,r) 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-1.9.35/src/Report.hs0000644000000000000000000000471212726504430013522 0ustar0000000000000000{-# 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) = "
  • " ++ escapeHTML name ++ " (" ++ show 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: " ++ n ++ "" else "" ,"
    " ,""] escapeHTML :: String -> String escapeHTML = concatMap f where f '>' = ">" f '<' = "<" f '&' = "&" f x = [x] hlint-1.9.35/src/Refact.hs0000644000000000000000000000065712726504430013457 0ustar0000000000000000module 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 . toSrcSpan . ann hlint-1.9.35/src/Parallel.hs0000644000000000000000000000236512726504430014005 0ustar0000000000000000{- 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 GHC.Conc(numCapabilities) import Control.Concurrent import Control.Exception import Control.Monad parallel :: [IO a] -> IO [a] parallel = if numCapabilities <= 1 then parallel1 else parallelN parallel1 :: [IO a] -> IO [a] parallel1 [] = return [] parallel1 (x:xs) = do x2 <- x xs2 <- unsafeInterleaveIO $ parallel1 xs return $ x2:xs2 parallelN :: [IO a] -> IO [a] parallelN xs = do ms <- mapM (const newEmptyMVar) xs chan <- newChan mapM_ (writeChan chan . Just) $ zip ms xs replicateM_ numCapabilities (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-1.9.35/src/Main.hs0000644000000000000000000000037212726504430013131 0ustar0000000000000000 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-1.9.35/src/Idea.hs0000644000000000000000000000613512726504430013112 0ustar0000000000000000{-# LANGUAGE RecordWildCards, NoMonomorphismRestriction #-} module Idea(module Idea, Note(..), showNotes, Severity(..)) where import Data.List.Extra import HSE.All import Settings 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) showIdeaJson :: Idea -> String showIdeaJson idea@Idea{ideaSpan=srcSpan@SrcSpan{..}, ..} = wrap . intercalate "," . map mkPair $ [("module", show ideaModule) ,("decl", show ideaDecl) ,("severity", show . show $ ideaSeverity) ,("hint", show ideaHint) ,("file", show srcSpanFilename) ,("startLine", show srcSpanStartLine) ,("startColumn", show srcSpanStartColumn) ,("endLine", show srcSpanEndLine) ,("endColumn", show srcSpanEndColumn) ,("from", show ideaFrom) ,("to", maybe "null" show ideaTo) ,("note", show $ map (show . show) ideaNote) ,("refactorings", show . show $ ideaRefactoring) ] where 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 (toSrcSpan $ ann from) (f from) (Just $ f to) [] where f = trimStart . prettyPrint suggest = idea Suggestion warn = idea Warning ideaN severity hint from to = rawIdea severity hint (toSrcSpan $ ann from) (f from) (Just $ f to) [] [] where f = trimStart . prettyPrint suggestN = ideaN Suggestion warnN = ideaN Warning hlint-1.9.35/src/HsColour.hs0000644000000000000000000000106012726504430013776 0ustar0000000000000000{-# 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-1.9.35/src/HLint.hs0000644000000000000000000001706712726504430013274 0ustar0000000000000000{-# LANGUAGE RecordWildCards, ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} module HLint(hlint) where import Control.Applicative import Control.Monad.Extra import Control.Exception import System.Console.CmdArgs.Verbosity import Data.List import System.Exit import System.IO.Extra import Data.Tuple.Extra import Prelude import Data.Version import System.Process.Extra import Data.Maybe import System.Directory import Text.ParserCombinators.ReadP import CmdLine import Settings import Report import Idea import Apply import Test.All import Grep import Test.Proof import Util import Parallel import HSE.All -- | 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 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 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 <- readSettings2 cmdDataDir 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 hlintGrep :: Cmd -> IO () hlintGrep cmd@CmdGrep{..} = do encoding <- if cmdUtf8 then return utf8 else readEncoding cmdEncoding let flags = parseFlagsSetLanguage (cmdExtensions cmd) $ defaultParseFlags{cppFlags=cmdCpp cmd, encoding=encoding} if null cmdFiles then exitWithHelp else do files <- concatMapM (resolveFile cmd Nothing) cmdFiles if null files then error "No files found" else runGrep cmdPattern flags files hlintMain :: Cmd -> IO [Idea] hlintMain cmd@CmdMain{..} = do encoding <- if cmdUtf8 then return utf8 else readEncoding cmdEncoding let flags = parseFlagsSetLanguage (cmdExtensions cmd) $ defaultParseFlags{cppFlags=cmdCpp cmd, encoding=encoding} if null cmdFiles && not (null cmdFindHints) then do hints <- concatMapM (resolveFile cmd Nothing) cmdFindHints mapM_ (putStrLn . fst <=< findSettings2 flags) hints >> return [] else if null cmdFiles then exitWithHelp else if cmdRefactor then withTempFile (\t -> runHlintMain cmd (Just t) flags) else runHlintMain cmd Nothing flags runHlintMain :: Cmd -> Maybe FilePath -> ParseFlags -> IO [Idea] runHlintMain cmd@CmdMain{..} fp flags = do files <- concatMapM (resolveFile cmd fp) cmdFiles if null files then error "No files found" else runHints cmd{cmdFiles=files} flags {-# ANN readAllSettings "HLint: ignore Use let" #-} readAllSettings :: Cmd -> ParseFlags -> IO [Setting] readAllSettings cmd@CmdMain{..} flags = do files <- cmdHintFiles cmd settings1 <- readSettings2 cmdDataDir files cmdWithHints settings2 <- concatMapM (fmap snd . findSettings2 flags) cmdFindHints settings3 <- return [SettingClassify $ Classify Ignore x "" "" | x <- cmdIgnore] return $ settings1 ++ settings2 ++ settings3 runHints :: Cmd -> ParseFlags -> IO [Idea] runHints cmd@CmdMain{..} flags = do let outStrLn = whenNormal . putStrLn settings <- readAllSettings cmd flags ideas <- if cmdCross then applyHintFiles flags settings cmdFiles else concat <$> parallel [evaluateList =<< applyHintFile flags settings x Nothing | x <- cmdFiles] let (showideas,hideideas) = partition (\i -> cmdShowAll || ideaSeverity i /= Ignore) ideas usecolour <- cmdUseColour cmd showItem <- if usecolour then showANSI else return show if cmdJson then putStrLn . showIdeasJson $ showideas else if cmdSerialise then do hSetBuffering stdout NoBuffering print $ map (show &&& ideaRefactoring) showideas else if cmdRefactor then 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) showideas withTempFile $ \f -> do writeFile f hints runRefactoring path file f cmdRefactorOptions -- Exit with the exit code from 'refactor' >>= exitWith _ -> error "Refactor flag can only be used with an individual file" else do mapM_ (outStrLn . showItem) showideas 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 $ outStrLn $ (let i = length showideas in if i == 0 then "No hints" else show i ++ " hint" ++ ['s' | i/=1]) ++ (let i = length hideideas in if i == 0 then "" else " (" ++ show i ++ " ignored)") return showideas 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 vers <- readP_to_S parseVersion . tail <$> readProcess exc ["--version"] "" case vers of [] -> putStrLn "Unabled to determine version of refactor" >> return exc (last -> (version, _)) -> if versionBranch version >= [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 = length xs `seq` return xs hlint-1.9.35/src/Grep.hs0000644000000000000000000000214212726504430013137 0ustar0000000000000000 module Grep(runGrep) where import Language.Haskell.HLint2 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-1.9.35/src/CmdLine.hs0000644000000000000000000003071512726504430013564 0ustar0000000000000000{-# LANGUAGE PatternGuards, RecordWildCards, DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-warn-missing-fields -fno-cse -O0 #-} module CmdLine(Cmd(..), cmdCpp, CppFlags(..), getCmd, cmdExtensions, cmdHintFiles, cmdUseColour, exitWithHelp, resolveFile) where 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 Language.Preprocessor.Cpphs import Language.Haskell.Exts(defaultParseMode, baseLanguage) import Language.Haskell.Exts.Extension import Data.Maybe import System.Environment 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 CmdMain{..} = do cmdDataDir <- if cmdDataDir == "" then getDataDir else return cmdDataDir cmdPath <- return $ if null cmdPath then ["."] else cmdPath cmdExtension <- return $ if null cmdExtension then ["hs", "lhs"] else cmdExtension return CmdMain{..} automatic CmdGrep{..} = do cmdPath <- return $ if null cmdPath then ["."] else cmdPath cmdExtension <- return $ if null cmdExtension then ["hs", "lhs"] else cmdExtension return CmdGrep{..} automatic CmdTest{..} = do cmdDataDir <- if cmdDataDir == "" then getDataDir else return cmdDataDir return CmdTest{..} automatic x = return x exitWithHelp :: IO a exitWithHelp = do putStr $ show $ helpText [] HelpFormatAll mode exitSuccess -- | 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. -- | 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 ,cmdColor :: ColorMode -- ^ color the result ,cmdIgnore :: [String] -- ^ the hints to ignore ,cmdShowAll :: Bool -- ^ display all skipped items ,cmdExtension :: [String] -- ^ extensions ,cmdLanguage :: [String] -- ^ the extensions (may be prefixed by "No") ,cmdUtf8 :: Bool ,cmdEncoding :: String -- ^ the text encoding ,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 ,cmdPath :: [String] ,cmdCppDefine :: [String] ,cmdCppInclude :: [FilePath] ,cmdCppFile :: [FilePath] ,cmdCppSimple :: Bool ,cmdCppAnsi :: Bool ,cmdJson :: Bool -- ^ display hint data as JSON ,cmdNoSummary :: Bool -- ^ do not show the summary info ,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") ,cmdUtf8 :: Bool ,cmdEncoding :: String -- ^ the text encoding ,cmdPath :: [String] ,cmdCppDefine :: [String] ,cmdCppInclude :: [FilePath] ,cmdCppFile :: [FilePath] ,cmdCppSimple :: Bool ,cmdCppAnsi :: Bool } | CmdTest {cmdProof :: [FilePath] -- ^ a proof script to check against ,cmdGivenHints :: [FilePath] -- ^ which settignsfiles 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" ,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)" ,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)" ,cmdUtf8 = nam "utf8" &= help "Use UTF-8 text encoding" ,cmdEncoding = nam_ "encoding" &= typ "ENCODING" &= help "Choose the text encoding" ,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" ,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" ,cmdNoSummary = nam_ "no-summary" &= help "Do not show summary information" ,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-2016") where nam xs = nam_ xs &= name [head xs] nam_ xs = def &= explicit &= name xs cmdHintFiles :: Cmd -> IO [FilePath] cmdHintFiles cmd = mapM (getHintFile $ cmdDataDir cmd) $ cmdGivenHints cmd ++ ["HLint" | null (cmdGivenHints cmd) && null (cmdWithHints cmd)] 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 -> FilePath -> 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 = error $ "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 getHintFile :: FilePath -> FilePath -> IO FilePath getHintFile _ "-" = return "-" getHintFile dataDir x = do let poss = nub $ concat [x : [x <.> "hs" | takeExtension x /= ".hs"] | x <- [x,dataDir x]] f poss poss where f o [] = error $ unlines $ [ "Couldn't find file: " ++ x, "Tried with:"] ++ map (" "++) o f o (x:xs) = do b <- doesFileExist x if b then return x else f o xs 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 = error $ "Unknown extension: " ++ x readExtension :: String -> Maybe Extension readExtension x = case classifyExtension x of UnknownExtension _ -> Nothing x -> Just x hlint-1.9.35/src/Apply.hs0000644000000000000000000001010612726504430013326 0ustar0000000000000000 module Apply(applyHints, applyHintFile, applyHintFiles) where import Control.Applicative import Data.Monoid import HSE.All import Hint.All import Data.Tuple.Extra import Data.Either import Data.List.Extra import Data.Maybe import Data.Ord import Settings import Idea 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 :: [Classify] -> Hint -> [(Module SrcSpanInfo, [Comment])] -> [Idea] applyHints cls hints_ ms = concat $ [ map (classify $ cls ++ mapMaybe readPragma (universeBi m)) $ order "" (hintModule hints nm m) `merge` concat [order (fromNamed d) $ decHints d | d <- moduleDecls m] `merge` concat [order "" $ hintComment hints c | c <- cs] | (nm,(m,cs)) <- mns , let decHints = hintDecl hints 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 $ map (second fst) mns)] where mns = map (scopeCreate . fst &&& id) ms hints = (if length ms <= 1 then noModules else id) hints_ noModules h = h{hintModules = const []} `mappend` mempty{hintModule = \a b -> hintModules h [(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 = applyHints [x | SettingClassify x <- 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{ideaHint = if "Parse error" `isPrefixOf` msg then msg else "Parse error: " ++ msg} -- | 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-1.9.35/src/Test/0000755000000000000000000000000012726504430012626 5ustar0000000000000000hlint-1.9.35/src/Test/Util.hs0000644000000000000000000000223112726504430014075 0ustar0000000000000000{-# 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-1.9.35/src/Test/Translate.hs0000644000000000000000000001100012726504430015107 0ustar0000000000000000 -- | 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 Paths_hlint import Settings import HSE.All import Test.Util runMains :: FilePath -> [String] -> IO () runMains 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] dat <- getDataDir res <- system $ "runhaskell -i" ++ dir ++ " -i" ++ dat ++ " Main" replicateM_ (length xs) $ tested $ res == ExitSuccess -- | Given a set of hints, do all the HintRule hints type check testTypeCheck :: FilePath -> [[Setting]] -> IO () testTypeCheck = wrap toTypeCheck -- | Given a set of hints, do all the HintRule hints satisfy QuickCheck testQuickCheck :: FilePath -> [[Setting]] -> IO () testQuickCheck = wrap toQuickCheck wrap :: ([HintRule] -> [String]) -> FilePath -> [[Setting]] -> IO () wrap f tmpdir hints = runMains 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-1.9.35/src/Test/Proof.hs0000644000000000000000000002124012726504430014246 0ustar0000000000000000{-# 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 Settings 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 SrcSpanInfo) | 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-1.9.35/src/Test/InputOutput.hs0000644000000000000000000000772312726504430015513 0ustar0000000000000000{-# 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-1.9.35/src/Test/Annotations.hs0000644000000000000000000000605112726504430015461 0ustar0000000000000000{-# 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 Settings 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 isJust (ideaTo $ head ideas) && -- detects parse failure 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 return $ f False $ zip [1..] $ 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-1.9.35/src/Test/All.hs0000644000000000000000000000425412726504430013677 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} module Test.All(test) where import Control.Monad import Data.List import System.Directory import System.FilePath import Data.Functor import Prelude import Settings import CmdLine import HSE.All import Hint.All import Test.Util import Test.InputOutput import Test.Annotations import Test.Translate import System.IO.Extra {-# ANN test "HLint: ignore Use let" #-} 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 == ".hs", not $ "HLint" `isPrefixOf` takeBaseName x] testFiles <- forM testFiles $ \file -> (,) file <$> readSettings2 dataDir [file] [] let wrap msg act = putStr (msg ++ " ") >> act >> putStrLn "" putStrLn "Testing" when useSrc $ wrap "Source annotations" $ forM_ builtinHints $ \(name,_) -> do progress; testAnnotations [Builtin name] $ "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 cmdTempDir [h | (file, h) <- testFiles, takeFileName file /= "Test.hs"] when cmdQuickCheck $ wrap "Hint QuickChecking" $ progress >> testQuickCheck 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 x)] | SettingMatchExp x@HintRule{} <- hints, hintRuleName x == defaultHintName] hlint-1.9.35/src/Language/0000755000000000000000000000000012726504430013432 5ustar0000000000000000hlint-1.9.35/src/Language/Haskell/0000755000000000000000000000000012726504430015015 5ustar0000000000000000hlint-1.9.35/src/Language/Haskell/HLint3.hs0000644000000000000000000001327512726504430016462 0ustar0000000000000000{-# LANGUAGE TupleSections, 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 Settings hiding (findSettings) import Idea import Apply import HLint import Hint.Type import Hint.All import CmdLine import Util import System.IO 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. -- Arugments 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'. (fixities, classify, hints) <- findSettings (readSettingsFile $ Just cmdDataDir) Nothing encoding <- if cmdUtf8 then return utf8 else readEncoding cmdEncoding let flags = parseFlagsSetLanguage (cmdExtensions cmd) $ parseFlagsAddFixities fixities $ defaultParseFlags{cppFlags = cmdCpp cmd, encoding = encoding} 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 | 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.HLint@) 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.HLint" start let flags = addInfix defaultParseFlags res <- parseModuleEx flags file contents case res of Left (ParseError sl msg err) -> error $ "Settings parse failure at " ++ showSrcLoc sl ++ ": " ++ msg ++ "\n" ++ err Right (m, _) -> do imported <- sequence [f $ fromNamed $ importModule i | i <- moduleImports m, importPkg i `elem` [Just "hint", Just "hlint"]] let (classify, rules) = Settings.readSettings m let fixities = getFixity =<< moduleDecls m return $ concatUnzip3 $ (fixities,classify,map Right rules) : imported where builtins = [(drop 4 $ show h, h :: HintBuiltin) | h <- [minBound .. maxBound]] f x | x == "HLint.Builtin.All" = return ([], [], map Left [minBound..maxBound]) f x | Just x <- "HLint.Builtin." `stripPrefix` x = case lookup x builtins of Just x -> return ([], [], [Left x]) Nothing -> error $ "Unknown builtin hints: HLint.Builtin." ++ x | otherwise = findSettings load (Just x) -- | 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-1.9.35/src/Language/Haskell/HLint2.hs0000644000000000000000000000575612726504430016466 0ustar0000000000000000 -- | /WARNING: This module represents the evolving second version of the HLint API./ -- /It will be deleted in favour of "Language.Haskell.HLint3" in the next major version./ -- -- This module provides a way to apply HLint hints. As an example of approximating the @hlint@ experience: -- -- @ -- (flags, classify, hint) <- 'autoSettings' -- Right m <- 'parseModuleEx' flags \"MyFile.hs\" Nothing -- print $ 'applyHints' classify hint [m] -- @ module Language.Haskell.HLint2( applyHints, -- * Idea data type Idea(..), Severity(..), Note(..), -- * Settings Classify(..), getHLintDataDir, autoSettings, autoSettings', findSettings, readSettings, -- * Hints Hint(..), builtinHints, HintRule(..), hintRules, -- * Scopes Scope, scopeCreate, scopeMatch, scopeMove, -- * Haskell-src-exts parseModuleEx, defaultParseFlags, ParseError(..), ParseFlags(..), CppFlags(..), -- * File encodings Encoding, defaultEncoding, readEncoding, useEncoding ) where import Settings import Idea import Apply import Hint.Type import Hint.All import Util import CmdLine import Paths_hlint import Control.Applicative import Data.Maybe import Data.Monoid import Data.Tuple.Extra import Data.List.Extra import System.FilePath import Prelude -- | Get the Cabal configured data directory of HLint getHLintDataDir :: IO FilePath getHLintDataDir = getDataDir resolveBuiltin :: [String] -> [Hint] resolveBuiltin builtin = map f $ nub $ concat [if x == "All" then map fst builtinHints else [x] | x <- builtin] where f x = fromMaybe (error $ "Unknown builtin hints: HLint.Builtin." ++ x) $ lookup x builtinHints -- | 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' to find and load the HLint settings files. -- -- 1. Use 'readSettings' to interpret the settings files, producing 'HintRule' values (@LHS ==> RHS@ replacements) -- and 'Classify' values to assign 'Severity' ratings to hints. -- -- 1. Use 'builtinHints' and 'hintRules' to generate a 'Hint' value. -- -- 1. Take all fixities from the 'findSettings' modules and put them in the 'ParseFlags'. autoSettings :: IO (ParseFlags, [Classify], Hint) autoSettings = getHLintDataDir >>= autoSettings' autoSettings' :: FilePath -> IO (ParseFlags, [Classify], Hint) autoSettings' dataDir = do (builtin, matches) <- first resolveBuiltin <$> findSettings dataDir (dataDir "HLint.hs") Nothing let (classify, rules) = second hintRules $ concatUnzip $ map readSettings matches let fixities = getFixity =<< moduleDecls =<< matches return (parseFlagsAddFixities fixities defaultParseFlags, classify, mconcat $ rules : builtin) -- | 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-1.9.35/src/Language/Haskell/HLint.hs0000644000000000000000000000267012726504430016374 0ustar0000000000000000{-| /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 Settings 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-1.9.35/src/HSE/0000755000000000000000000000000012726504430012326 5ustar0000000000000000hlint-1.9.35/src/HSE/Util.hs0000644000000000000000000002234112726504430013601 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module HSE.Util(module HSE.Util) where import Control.Monad import Data.List import Data.Maybe import System.FilePath import HSE.Type import Language.Haskell.Exts.Annotated.Simplify(sQName, sAssoc) import Prelude --------------------------------------------------------------------- -- ACCESSOR/TESTER 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 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 isList List{} = True; isList _ = 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 isPatTypeSig PatTypeSig{} = True; isPatTypeSig _ = False isQuasiQuote QuasiQuote{} = True; isQuasiQuote _ = False isSpliceDecl SpliceDecl{} = True; isSpliceDecl _ = False isNewType NewType{} = True; isNewType _ = False isRecStmt RecStmt{} = True; isRecStmt _ = False isClsDefSig ClsDefSig{} = True; isClsDefSig _ = False isSection LeftSection{} = True isSection RightSection{} = True isSection _ = 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 S -> Name S fromQual (Qual _ _ x) = x fromQual (UnQual _ x) = x fromQual x = error $ "HSE.Util.fromQual, not a name: " ++ prettyPrint x 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 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 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 :: Biplate x (f S) => x -> [f S] universeS = universeBi childrenS :: Biplate x (f S) => x -> [f S] childrenS = childrenBi -- return the parent along with the child universeParentExp :: Biplate a Exp_ => 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 [] = [] toSrcSpan :: SrcSpanInfo -> SrcSpan toSrcSpan (SrcSpanInfo x _) = x nullSrcLoc :: SrcLoc nullSrcLoc = SrcLoc "" 0 0 nullSrcSpan :: SrcSpan nullSrcSpan = mkSrcSpan nullSrcLoc nullSrcLoc an :: SrcSpanInfo an = toSrcInfo nullSrcLoc [] nullSrcLoc dropAnn :: Functor f => f s -> 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 (=~=) 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 (sAssoc a) (fromMaybe 9 mp) (sQName $ UnQual sl $ f op) | op <- ops] where f (VarOp _ x) = x f (ConOp _ x) = x getFixity _ = [] hlint-1.9.35/src/HSE/Type.hs0000644000000000000000000011106312726504430013605 0ustar0000000000000000 module HSE.Type(module HSE.Type, module Export) 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.Annotated as Export hiding (parse, loc, paren, Assoc(..)) import Language.Haskell.Exts as Export(Assoc(..)) import Data.Generics.Uniplate.Data as Export type S = SrcSpanInfo type Module_ = Module S type Decl_ = Decl S type Exp_ = Exp S type Pat_ = Pat S type Type_ = Type S {-! deriving instance UniplateDirect (Pat S) (Pat S) deriving instance UniplateDirect (Exp S) deriving instance UniplateDirect (Pat S) deriving instance UniplateDirect (Pat S) (Exp S) deriving instance UniplateDirect (Binds S) (Exp S) deriving instance UniplateDirect (Alt S) (Exp S) deriving instance UniplateDirect (Stmt S) (Exp S) deriving instance UniplateDirect (QualStmt S) (Exp S) deriving instance UniplateDirect [QualStmt S] (Exp S) deriving instance UniplateDirect (Bracket S) (Exp S) deriving instance UniplateDirect (Splice S) (Exp S) deriving instance UniplateDirect (XAttr S) (Exp S) deriving instance UniplateDirect (Maybe (Exp S)) (Exp S) deriving instance UniplateDirect (FieldUpdate S) (Exp S) deriving instance UniplateDirect (PatField S) (Pat S) deriving instance UniplateDirect (Exp S) (Pat S) deriving instance UniplateDirect (RPat S) (Pat S) deriving instance UniplateDirect (PXAttr S) (Pat S) deriving instance UniplateDirect (Maybe (Pat S)) (Pat S) deriving instance UniplateDirect (PatField S) (Exp S) deriving instance UniplateDirect (RPat S) (Exp S) deriving instance UniplateDirect (PXAttr S) (Exp S) deriving instance UniplateDirect (Maybe (Pat S)) (Exp S) deriving instance UniplateDirect (Decl S) (Exp S) deriving instance UniplateDirect (IPBind S) (Exp S) deriving instance UniplateDirect (GuardedAlts S) (Exp S) deriving instance UniplateDirect (Maybe (Binds S)) (Exp S) deriving instance UniplateDirect (Maybe (Exp S)) (Exp S) deriving instance UniplateDirect (FieldUpdate S) (Exp S) deriving instance UniplateDirect (PatField S) (Pat S) deriving instance UniplateDirect (Exp S) (Pat S) deriving instance UniplateDirect (RPat S) (Pat S) deriving instance UniplateDirect (PXAttr S) (Pat S) deriving instance UniplateDirect (Maybe (Pat S)) (Pat S) deriving instance UniplateDirect (PatField S) (Exp S) deriving instance UniplateDirect (RPat S) (Exp S) deriving instance UniplateDirect (PXAttr S) (Exp S) deriving instance UniplateDirect (Maybe (Pat S)) (Exp S) deriving instance UniplateDirect (Decl S) (Exp S) deriving instance UniplateDirect (IPBind S) (Exp S) deriving instance UniplateDirect (GuardedAlts S) (Exp S) deriving instance UniplateDirect (Maybe (Binds S)) (Exp S) deriving instance UniplateDirect (Binds S) (Pat S) deriving instance UniplateDirect (Alt S) (Pat S) deriving instance UniplateDirect (Stmt S) (Pat S) deriving instance UniplateDirect (Maybe (Exp S)) (Pat S) deriving instance UniplateDirect (FieldUpdate S) (Pat S) deriving instance UniplateDirect (QualStmt S) (Pat S) deriving instance UniplateDirect [QualStmt S] (Pat S) deriving instance UniplateDirect (Bracket S) (Pat S) deriving instance UniplateDirect (Splice S) (Pat S) deriving instance UniplateDirect (XAttr S) (Pat S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (Exp S) deriving instance UniplateDirect (Maybe [InstDecl S]) (Exp S) deriving instance UniplateDirect (Match S) (Exp S) deriving instance UniplateDirect (Rhs S) (Exp S) deriving instance UniplateDirect (Rule S) (Exp S) deriving instance UniplateDirect (GuardedAlt S) (Exp S) deriving instance UniplateDirect (Decl S) (Pat S) deriving instance UniplateDirect (IPBind S) (Pat S) deriving instance UniplateDirect (GuardedAlts S) (Pat S) deriving instance UniplateDirect (Maybe (Binds S)) (Pat S) deriving instance UniplateDirect (ClassDecl S) (Exp S) deriving instance UniplateDirect (InstDecl S) (Exp S) deriving instance UniplateDirect (GuardedRhs S) (Exp S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (Pat S) deriving instance UniplateDirect (Maybe [InstDecl S]) (Pat S) deriving instance UniplateDirect (Match S) (Pat S) deriving instance UniplateDirect (Rhs S) (Pat S) deriving instance UniplateDirect (Rule S) (Pat S) deriving instance UniplateDirect (GuardedAlt S) (Pat S) deriving instance UniplateDirect (ClassDecl S) (Pat S) deriving instance UniplateDirect (InstDecl S) (Pat S) deriving instance UniplateDirect (GuardedRhs S) (Pat S) deriving instance UniplateDirect (Maybe (Binds S)) (Decl S) deriving instance UniplateDirect (Exp S) (Name S) deriving instance UniplateDirect (Decl S) deriving instance UniplateDirect (Binds S) (Decl S) deriving instance UniplateDirect (Name S) deriving instance UniplateDirect (QName S) (Name S) deriving instance UniplateDirect (QOp S) (Name S) deriving instance UniplateDirect (Pat S) (Name S) deriving instance UniplateDirect (Binds S) (Name S) deriving instance UniplateDirect (Alt S) (Name S) deriving instance UniplateDirect (Stmt S) (Name S) deriving instance UniplateDirect (Maybe (Exp S)) (Name S) deriving instance UniplateDirect (FieldUpdate S) (Name S) deriving instance UniplateDirect (QualStmt S) (Name S) deriving instance UniplateDirect [QualStmt S] (Name S) deriving instance UniplateDirect (Type S) (Name S) deriving instance UniplateDirect (Bracket S) (Name S) deriving instance UniplateDirect (Splice S) (Name S) deriving instance UniplateDirect (XAttr S) (Name S) deriving instance UniplateDirect (Decl S) (Name S) deriving instance UniplateDirect (Exp S) (Decl S) deriving instance UniplateDirect (GuardedAlts S) (Name S) deriving instance UniplateDirect (IPBind S) (Decl S) deriving instance UniplateDirect (IPBind S) (Name S) deriving instance UniplateDirect (Kind S) (Name S) deriving instance UniplateDirect (Match S) (Decl S) deriving instance UniplateDirect (Maybe (Binds S)) (Name S) deriving instance UniplateDirect (Maybe (Context S)) (Name S) deriving instance UniplateDirect (Maybe (Pat S)) (Name S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (Decl S) deriving instance UniplateDirect (Maybe [InstDecl S]) (Decl S) deriving instance UniplateDirect (Maybe [TyVarBind S]) (Name S) deriving instance UniplateDirect (PXAttr S) (Name S) deriving instance UniplateDirect (Pat S) (Decl S) deriving instance UniplateDirect (PatField S) (Name S) deriving instance UniplateDirect (RPat S) (Name S) deriving instance UniplateDirect (Rhs S) (Decl S) deriving instance UniplateDirect (Rule S) (Decl S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (Name S) deriving instance UniplateDirect (InstHead S) (Name S) deriving instance UniplateDirect (Maybe [InstDecl S]) (Name S) deriving instance UniplateDirect (Op S) (Name S) deriving instance UniplateDirect (Match S) (Name S) deriving instance UniplateDirect (Maybe (Type S)) (Name S) deriving instance UniplateDirect (Rhs S) (Name S) deriving instance UniplateDirect (Rule S) (Name S) deriving instance UniplateDirect ([Name S], String) (Name S) deriving instance UniplateDirect (Alt S) (Decl S) deriving instance UniplateDirect (Stmt S) (Decl S) deriving instance UniplateDirect (Maybe (Exp S)) (Decl S) deriving instance UniplateDirect (FieldUpdate S) (Decl S) deriving instance UniplateDirect (QualStmt S) (Decl S) deriving instance UniplateDirect [QualStmt S] (Decl S) deriving instance UniplateDirect (Bracket S) (Decl S) deriving instance UniplateDirect (Splice S) (Decl S) deriving instance UniplateDirect (XAttr S) (Decl S) deriving instance UniplateDirect (GuardedAlt S) (Name S) deriving instance UniplateDirect (Context S) (Name S) deriving instance UniplateDirect (ClassDecl S) (Decl S) deriving instance UniplateDirect (InstDecl S) (Decl S) deriving instance UniplateDirect (TyVarBind S) (Name S) deriving instance UniplateDirect (PatField S) (Decl S) deriving instance UniplateDirect (RPat S) (Decl S) deriving instance UniplateDirect (PXAttr S) (Decl S) deriving instance UniplateDirect (Maybe (Pat S)) (Decl S) deriving instance UniplateDirect (GuardedRhs S) (Decl S) deriving instance UniplateDirect (DeclHead S) (Name S) deriving instance UniplateDirect (Maybe (Kind S)) (Name S) deriving instance UniplateDirect (QualConDecl S) (Name S) deriving instance UniplateDirect (Maybe (Deriving S)) (Name S) deriving instance UniplateDirect (GadtDecl S) (Name S) deriving instance UniplateDirect (FunDep S) (Name S) deriving instance UniplateDirect (ClassDecl S) (Name S) deriving instance UniplateDirect (InstDecl S) (Name S) deriving instance UniplateDirect (GuardedRhs S) (Name S) deriving instance UniplateDirect (Maybe [RuleVar S]) (Name S) deriving instance UniplateDirect (GuardedAlts S) (Decl S) deriving instance UniplateDirect (Asst S) (Name S) deriving instance UniplateDirect (ConDecl S) (Name S) deriving instance UniplateDirect (Deriving S) (Name S) deriving instance UniplateDirect (RuleVar S) (Name S) deriving instance UniplateDirect (GuardedAlt S) (Decl S) deriving instance UniplateDirect (BangType S) (Name S) deriving instance UniplateDirect (FieldDecl S) (Name S) deriving instance UniplateDirect (Module S) (FunDep S) deriving instance UniplateDirect (Module S) (IPName S) deriving instance UniplateDirect (Module S) (Decl S) deriving instance UniplateDirect (Module S) (Kind S) deriving instance UniplateDirect (Module S) (Pat S) deriving instance UniplateDirect (Module S) (CallConv S) deriving instance UniplateDirect (Module S) (GuardedRhs S) deriving instance UniplateDirect (Module S) (GuardedAlt S) deriving instance UniplateDirect (Module S) (PatField S) deriving instance UniplateDirect (Module S) Boxed deriving instance UniplateDirect (Module S) (ImportDecl S) deriving instance UniplateDirect (Module S) (Exp S) deriving instance UniplateDirect (Module S) (QualStmt S) deriving instance UniplateDirect (Exp S) (CallConv S) deriving instance UniplateDirect (GuardedRhs S) deriving instance UniplateDirect (Decl S) (GuardedRhs S) deriving instance UniplateDirect (XAttr S) (GuardedRhs S) deriving instance UniplateDirect (Maybe (Exp S)) (GuardedRhs S) deriving instance UniplateDirect (Exp S) (GuardedRhs S) deriving instance UniplateDirect (GuardedAlt S) deriving instance UniplateDirect (Decl S) (GuardedAlt S) deriving instance UniplateDirect (XAttr S) (GuardedAlt S) deriving instance UniplateDirect (Maybe (Exp S)) (GuardedAlt S) deriving instance UniplateDirect (Exp S) (GuardedAlt S) deriving instance UniplateDirect (PatField S) deriving instance UniplateDirect (Decl S) (PatField S) deriving instance UniplateDirect (XAttr S) (PatField S) deriving instance UniplateDirect (Maybe (Exp S)) (PatField S) deriving instance UniplateDirect (Exp S) (PatField S) deriving instance UniplateDirect Boxed deriving instance UniplateDirect (Maybe (ModuleHead S)) Boxed deriving instance UniplateDirect (Decl S) Boxed deriving instance UniplateDirect (XAttr S) Boxed deriving instance UniplateDirect (Maybe (Exp S)) Boxed deriving instance UniplateDirect (Exp S) Boxed deriving instance UniplateDirect (ImportDecl S) deriving instance UniplateDirect (QualStmt S) deriving instance UniplateDirect (Decl S) (QualStmt S) deriving instance UniplateDirect (XAttr S) (QualStmt S) deriving instance UniplateDirect (Maybe (Exp S)) (QualStmt S) deriving instance UniplateDirect (Exp S) (QualStmt S) deriving instance UniplateDirect (Maybe (Type S)) Boxed deriving instance UniplateDirect (Rhs S) Boxed deriving instance UniplateDirect (Maybe (Binds S)) Boxed deriving instance UniplateDirect (Rule S) Boxed deriving instance UniplateDirect (QName S) Boxed deriving instance UniplateDirect (QOp S) Boxed deriving instance UniplateDirect (Binds S) Boxed deriving instance UniplateDirect (Alt S) Boxed deriving instance UniplateDirect (Stmt S) Boxed deriving instance UniplateDirect (FieldUpdate S) Boxed deriving instance UniplateDirect (QualStmt S) Boxed deriving instance UniplateDirect [QualStmt S] Boxed deriving instance UniplateDirect (Bracket S) Boxed deriving instance UniplateDirect (Splice S) Boxed deriving instance UniplateDirect (Stmt S) (QualStmt S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (QualStmt S) deriving instance UniplateDirect (Maybe [InstDecl S]) (QualStmt S) deriving instance UniplateDirect (Match S) (QualStmt S) deriving instance UniplateDirect (Pat S) (QualStmt S) deriving instance UniplateDirect (Rhs S) (QualStmt S) deriving instance UniplateDirect (Maybe (Binds S)) (QualStmt S) deriving instance UniplateDirect (Rule S) (QualStmt S) deriving instance UniplateDirect (Binds S) (QualStmt S) deriving instance UniplateDirect (Alt S) (QualStmt S) deriving instance UniplateDirect (FieldUpdate S) (QualStmt S) deriving instance UniplateDirect [QualStmt S] (QualStmt S) deriving instance UniplateDirect (Bracket S) (QualStmt S) deriving instance UniplateDirect (Splice S) (QualStmt S) deriving instance UniplateDirect (FunDep S) deriving instance UniplateDirect (Decl S) (FunDep S) deriving instance UniplateDirect (XAttr S) (FunDep S) deriving instance UniplateDirect (Maybe (Exp S)) (FunDep S) deriving instance UniplateDirect (Exp S) (FunDep S) deriving instance UniplateDirect (IPName S) deriving instance UniplateDirect (Decl S) (IPName S) deriving instance UniplateDirect (XAttr S) (IPName S) deriving instance UniplateDirect (Maybe (Exp S)) (IPName S) deriving instance UniplateDirect (Exp S) (IPName S) deriving instance UniplateDirect (Kind S) deriving instance UniplateDirect (Decl S) (Kind S) deriving instance UniplateDirect (XAttr S) (Kind S) deriving instance UniplateDirect (Maybe (Exp S)) (Kind S) deriving instance UniplateDirect (Exp S) (Kind S) deriving instance UniplateDirect (CallConv S) deriving instance UniplateDirect (Decl S) (CallConv S) deriving instance UniplateDirect (XAttr S) (CallConv S) deriving instance UniplateDirect (Maybe (Exp S)) (CallConv S) deriving instance UniplateDirect (CallConv S) deriving instance UniplateDirect (Pat S) (CallConv S) deriving instance UniplateDirect (Binds S) (CallConv S) deriving instance UniplateDirect (Alt S) (CallConv S) deriving instance UniplateDirect (Stmt S) (CallConv S) deriving instance UniplateDirect (FieldUpdate S) (CallConv S) deriving instance UniplateDirect (QualStmt S) (CallConv S) deriving instance UniplateDirect [QualStmt S] (CallConv S) deriving instance UniplateDirect (Bracket S) (CallConv S) deriving instance UniplateDirect (Splice S) (CallConv S) deriving instance UniplateDirect (Stmt S) (GuardedRhs S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (GuardedRhs S) deriving instance UniplateDirect (Maybe [InstDecl S]) (GuardedRhs S) deriving instance UniplateDirect (Match S) (GuardedRhs S) deriving instance UniplateDirect (Pat S) (GuardedRhs S) deriving instance UniplateDirect (Rhs S) (GuardedRhs S) deriving instance UniplateDirect (Maybe (Binds S)) (GuardedRhs S) deriving instance UniplateDirect (Rule S) (GuardedRhs S) deriving instance UniplateDirect (Binds S) (GuardedRhs S) deriving instance UniplateDirect (Alt S) (GuardedRhs S) deriving instance UniplateDirect (FieldUpdate S) (GuardedRhs S) deriving instance UniplateDirect (QualStmt S) (GuardedRhs S) deriving instance UniplateDirect [QualStmt S] (GuardedRhs S) deriving instance UniplateDirect (Bracket S) (GuardedRhs S) deriving instance UniplateDirect (Splice S) (GuardedRhs S) deriving instance UniplateDirect (Stmt S) (GuardedAlt S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (GuardedAlt S) deriving instance UniplateDirect (Maybe [InstDecl S]) (GuardedAlt S) deriving instance UniplateDirect (Match S) (GuardedAlt S) deriving instance UniplateDirect (Pat S) (GuardedAlt S) deriving instance UniplateDirect (Rhs S) (GuardedAlt S) deriving instance UniplateDirect (Maybe (Binds S)) (GuardedAlt S) deriving instance UniplateDirect (Rule S) (GuardedAlt S) deriving instance UniplateDirect (Binds S) (GuardedAlt S) deriving instance UniplateDirect (Alt S) (GuardedAlt S) deriving instance UniplateDirect (FieldUpdate S) (GuardedAlt S) deriving instance UniplateDirect (QualStmt S) (GuardedAlt S) deriving instance UniplateDirect [QualStmt S] (GuardedAlt S) deriving instance UniplateDirect (Bracket S) (GuardedAlt S) deriving instance UniplateDirect (Splice S) (GuardedAlt S) deriving instance UniplateDirect (Pat S) (PatField S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (PatField S) deriving instance UniplateDirect (Maybe [InstDecl S]) (PatField S) deriving instance UniplateDirect (Match S) (PatField S) deriving instance UniplateDirect (Rhs S) (PatField S) deriving instance UniplateDirect (Maybe (Binds S)) (PatField S) deriving instance UniplateDirect (Rule S) (PatField S) deriving instance UniplateDirect (Binds S) (PatField S) deriving instance UniplateDirect (Alt S) (PatField S) deriving instance UniplateDirect (Stmt S) (PatField S) deriving instance UniplateDirect (FieldUpdate S) (PatField S) deriving instance UniplateDirect (QualStmt S) (PatField S) deriving instance UniplateDirect [QualStmt S] (PatField S) deriving instance UniplateDirect (Bracket S) (PatField S) deriving instance UniplateDirect (Splice S) (PatField S) deriving instance UniplateDirect (ModuleHead S) Boxed deriving instance UniplateDirect (Type S) Boxed deriving instance UniplateDirect (Maybe (Context S)) Boxed deriving instance UniplateDirect (QualConDecl S) Boxed deriving instance UniplateDirect (Maybe (Deriving S)) Boxed deriving instance UniplateDirect (GadtDecl S) Boxed deriving instance UniplateDirect (Maybe [ClassDecl S]) Boxed deriving instance UniplateDirect (InstHead S) Boxed deriving instance UniplateDirect (Maybe [InstDecl S]) Boxed deriving instance UniplateDirect (Match S) Boxed deriving instance UniplateDirect (Pat S) Boxed deriving instance UniplateDirect (GuardedRhs S) Boxed deriving instance UniplateDirect (Maybe [RuleVar S]) Boxed deriving instance UniplateDirect (SpecialCon S) Boxed deriving instance UniplateDirect (IPBind S) Boxed deriving instance UniplateDirect (GuardedAlts S) Boxed deriving instance UniplateDirect (ClassDecl S) (QualStmt S) deriving instance UniplateDirect (InstDecl S) (QualStmt S) deriving instance UniplateDirect (PatField S) (QualStmt S) deriving instance UniplateDirect (RPat S) (QualStmt S) deriving instance UniplateDirect (PXAttr S) (QualStmt S) deriving instance UniplateDirect (Maybe (Pat S)) (QualStmt S) deriving instance UniplateDirect (GuardedRhs S) (QualStmt S) deriving instance UniplateDirect (IPBind S) (QualStmt S) deriving instance UniplateDirect (GuardedAlts S) (QualStmt S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (FunDep S) deriving instance UniplateDirect (Maybe [InstDecl S]) (FunDep S) deriving instance UniplateDirect (Match S) (FunDep S) deriving instance UniplateDirect (Pat S) (FunDep S) deriving instance UniplateDirect (Rhs S) (FunDep S) deriving instance UniplateDirect (Maybe (Binds S)) (FunDep S) deriving instance UniplateDirect (Rule S) (FunDep S) deriving instance UniplateDirect (Binds S) (FunDep S) deriving instance UniplateDirect (Alt S) (FunDep S) deriving instance UniplateDirect (Stmt S) (FunDep S) deriving instance UniplateDirect (FieldUpdate S) (FunDep S) deriving instance UniplateDirect (QualStmt S) (FunDep S) deriving instance UniplateDirect [QualStmt S] (FunDep S) deriving instance UniplateDirect (Bracket S) (FunDep S) deriving instance UniplateDirect (Splice S) (FunDep S) deriving instance UniplateDirect (Type S) (IPName S) deriving instance UniplateDirect (Maybe (Context S)) (IPName S) deriving instance UniplateDirect (QualConDecl S) (IPName S) deriving instance UniplateDirect (Maybe (Deriving S)) (IPName S) deriving instance UniplateDirect (GadtDecl S) (IPName S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (IPName S) deriving instance UniplateDirect (InstHead S) (IPName S) deriving instance UniplateDirect (Maybe [InstDecl S]) (IPName S) deriving instance UniplateDirect (Match S) (IPName S) deriving instance UniplateDirect (Pat S) (IPName S) deriving instance UniplateDirect (Maybe (Type S)) (IPName S) deriving instance UniplateDirect (Rhs S) (IPName S) deriving instance UniplateDirect (Maybe (Binds S)) (IPName S) deriving instance UniplateDirect (Rule S) (IPName S) deriving instance UniplateDirect (Binds S) (IPName S) deriving instance UniplateDirect (Alt S) (IPName S) deriving instance UniplateDirect (Stmt S) (IPName S) deriving instance UniplateDirect (FieldUpdate S) (IPName S) deriving instance UniplateDirect (QualStmt S) (IPName S) deriving instance UniplateDirect [QualStmt S] (IPName S) deriving instance UniplateDirect (Bracket S) (IPName S) deriving instance UniplateDirect (Splice S) (IPName S) deriving instance UniplateDirect (DeclHead S) (Kind S) deriving instance UniplateDirect (Type S) (Kind S) deriving instance UniplateDirect (Maybe (Kind S)) (Kind S) deriving instance UniplateDirect (Maybe (Context S)) (Kind S) deriving instance UniplateDirect (QualConDecl S) (Kind S) deriving instance UniplateDirect (Maybe (Deriving S)) (Kind S) deriving instance UniplateDirect (GadtDecl S) (Kind S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (Kind S) deriving instance UniplateDirect (InstHead S) (Kind S) deriving instance UniplateDirect (Maybe [InstDecl S]) (Kind S) deriving instance UniplateDirect (Match S) (Kind S) deriving instance UniplateDirect (Pat S) (Kind S) deriving instance UniplateDirect (Maybe (Type S)) (Kind S) deriving instance UniplateDirect (Rhs S) (Kind S) deriving instance UniplateDirect (Maybe (Binds S)) (Kind S) deriving instance UniplateDirect (Rule S) (Kind S) deriving instance UniplateDirect (Binds S) (Kind S) deriving instance UniplateDirect (Alt S) (Kind S) deriving instance UniplateDirect (Stmt S) (Kind S) deriving instance UniplateDirect (FieldUpdate S) (Kind S) deriving instance UniplateDirect (QualStmt S) (Kind S) deriving instance UniplateDirect [QualStmt S] (Kind S) deriving instance UniplateDirect (Bracket S) (Kind S) deriving instance UniplateDirect (Splice S) (Kind S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (CallConv S) deriving instance UniplateDirect (Maybe [InstDecl S]) (CallConv S) deriving instance UniplateDirect (Match S) (CallConv S) deriving instance UniplateDirect (Rhs S) (CallConv S) deriving instance UniplateDirect (Maybe (Binds S)) (CallConv S) deriving instance UniplateDirect (Rule S) (CallConv S) deriving instance UniplateDirect (PatField S) (CallConv S) deriving instance UniplateDirect (RPat S) (CallConv S) deriving instance UniplateDirect (PXAttr S) (CallConv S) deriving instance UniplateDirect (Maybe (Pat S)) (CallConv S) deriving instance UniplateDirect (IPBind S) (CallConv S) deriving instance UniplateDirect (GuardedAlts S) (CallConv S) deriving instance UniplateDirect (ClassDecl S) (GuardedRhs S) deriving instance UniplateDirect (InstDecl S) (GuardedRhs S) deriving instance UniplateDirect (PatField S) (GuardedRhs S) deriving instance UniplateDirect (RPat S) (GuardedRhs S) deriving instance UniplateDirect (PXAttr S) (GuardedRhs S) deriving instance UniplateDirect (Maybe (Pat S)) (GuardedRhs S) deriving instance UniplateDirect (IPBind S) (GuardedRhs S) deriving instance UniplateDirect (GuardedAlts S) (GuardedRhs S) deriving instance UniplateDirect (ClassDecl S) (GuardedAlt S) deriving instance UniplateDirect (InstDecl S) (GuardedAlt S) deriving instance UniplateDirect (PatField S) (GuardedAlt S) deriving instance UniplateDirect (RPat S) (GuardedAlt S) deriving instance UniplateDirect (PXAttr S) (GuardedAlt S) deriving instance UniplateDirect (Maybe (Pat S)) (GuardedAlt S) deriving instance UniplateDirect (GuardedRhs S) (GuardedAlt S) deriving instance UniplateDirect (IPBind S) (GuardedAlt S) deriving instance UniplateDirect (GuardedAlts S) (GuardedAlt S) deriving instance UniplateDirect (RPat S) (PatField S) deriving instance UniplateDirect (PXAttr S) (PatField S) deriving instance UniplateDirect (Maybe (Pat S)) (PatField S) deriving instance UniplateDirect (ClassDecl S) (PatField S) deriving instance UniplateDirect (InstDecl S) (PatField S) deriving instance UniplateDirect (GuardedRhs S) (PatField S) deriving instance UniplateDirect (IPBind S) (PatField S) deriving instance UniplateDirect (GuardedAlts S) (PatField S) deriving instance UniplateDirect (Maybe (ExportSpecList S)) Boxed deriving instance UniplateDirect (Context S) Boxed deriving instance UniplateDirect (ConDecl S) Boxed deriving instance UniplateDirect (Deriving S) Boxed deriving instance UniplateDirect (ClassDecl S) Boxed deriving instance UniplateDirect (InstDecl S) Boxed deriving instance UniplateDirect (PatField S) Boxed deriving instance UniplateDirect (RPat S) Boxed deriving instance UniplateDirect (PXAttr S) Boxed deriving instance UniplateDirect (Maybe (Pat S)) Boxed deriving instance UniplateDirect (RuleVar S) Boxed deriving instance UniplateDirect (GuardedAlt S) Boxed deriving instance UniplateDirect (GuardedAlt S) (QualStmt S) deriving instance UniplateDirect (ClassDecl S) (FunDep S) deriving instance UniplateDirect (InstDecl S) (FunDep S) deriving instance UniplateDirect (PatField S) (FunDep S) deriving instance UniplateDirect (RPat S) (FunDep S) deriving instance UniplateDirect (PXAttr S) (FunDep S) deriving instance UniplateDirect (Maybe (Pat S)) (FunDep S) deriving instance UniplateDirect (GuardedRhs S) (FunDep S) deriving instance UniplateDirect (IPBind S) (FunDep S) deriving instance UniplateDirect (GuardedAlts S) (FunDep S) deriving instance UniplateDirect (Context S) (IPName S) deriving instance UniplateDirect (ConDecl S) (IPName S) deriving instance UniplateDirect (Deriving S) (IPName S) deriving instance UniplateDirect (ClassDecl S) (IPName S) deriving instance UniplateDirect (InstDecl S) (IPName S) deriving instance UniplateDirect (PatField S) (IPName S) deriving instance UniplateDirect (RPat S) (IPName S) deriving instance UniplateDirect (PXAttr S) (IPName S) deriving instance UniplateDirect (Maybe (Pat S)) (IPName S) deriving instance UniplateDirect (GuardedRhs S) (IPName S) deriving instance UniplateDirect (Maybe [RuleVar S]) (IPName S) deriving instance UniplateDirect (IPBind S) (IPName S) deriving instance UniplateDirect (GuardedAlts S) (IPName S) deriving instance UniplateDirect (TyVarBind S) (Kind S) deriving instance UniplateDirect (Maybe [TyVarBind S]) (Kind S) deriving instance UniplateDirect (Context S) (Kind S) deriving instance UniplateDirect (ConDecl S) (Kind S) deriving instance UniplateDirect (Deriving S) (Kind S) deriving instance UniplateDirect (ClassDecl S) (Kind S) deriving instance UniplateDirect (InstDecl S) (Kind S) deriving instance UniplateDirect (PatField S) (Kind S) deriving instance UniplateDirect (RPat S) (Kind S) deriving instance UniplateDirect (PXAttr S) (Kind S) deriving instance UniplateDirect (Maybe (Pat S)) (Kind S) deriving instance UniplateDirect (GuardedRhs S) (Kind S) deriving instance UniplateDirect (Maybe [RuleVar S]) (Kind S) deriving instance UniplateDirect (IPBind S) (Kind S) deriving instance UniplateDirect (GuardedAlts S) (Kind S) deriving instance UniplateDirect (ClassDecl S) (CallConv S) deriving instance UniplateDirect (InstDecl S) (CallConv S) deriving instance UniplateDirect (GuardedRhs S) (CallConv S) deriving instance UniplateDirect (GuardedAlt S) (CallConv S) deriving instance UniplateDirect (GuardedAlt S) (GuardedRhs S) deriving instance UniplateDirect (GuardedAlt S) (PatField S) deriving instance UniplateDirect (ExportSpecList S) Boxed deriving instance UniplateDirect (Asst S) Boxed deriving instance UniplateDirect (BangType S) Boxed deriving instance UniplateDirect (FieldDecl S) Boxed deriving instance UniplateDirect (GuardedAlt S) (FunDep S) deriving instance UniplateDirect (Asst S) (IPName S) deriving instance UniplateDirect (BangType S) (IPName S) deriving instance UniplateDirect (FieldDecl S) (IPName S) deriving instance UniplateDirect (RuleVar S) (IPName S) deriving instance UniplateDirect (GuardedAlt S) (IPName S) deriving instance UniplateDirect (Asst S) (Kind S) deriving instance UniplateDirect (BangType S) (Kind S) deriving instance UniplateDirect (FieldDecl S) (Kind S) deriving instance UniplateDirect (RuleVar S) (Kind S) deriving instance UniplateDirect (GuardedAlt S) (Kind S) deriving instance UniplateDirect (ExportSpec S) Boxed deriving instance UniplateDirect (Module S) (Splice S) deriving instance UniplateDirect (Module S) (Bracket S) deriving instance UniplateDirect (Splice S) deriving instance UniplateDirect (Decl S) (Splice S) deriving instance UniplateDirect (XAttr S) (Splice S) deriving instance UniplateDirect (Maybe (Exp S)) (Splice S) deriving instance UniplateDirect (Exp S) (Splice S) deriving instance UniplateDirect (Bracket S) deriving instance UniplateDirect (Decl S) (Bracket S) deriving instance UniplateDirect (XAttr S) (Bracket S) deriving instance UniplateDirect (Maybe (Exp S)) (Bracket S) deriving instance UniplateDirect (Exp S) (Bracket S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (Splice S) deriving instance UniplateDirect (Maybe [InstDecl S]) (Splice S) deriving instance UniplateDirect (Match S) (Splice S) deriving instance UniplateDirect (Pat S) (Splice S) deriving instance UniplateDirect (Rhs S) (Splice S) deriving instance UniplateDirect (Maybe (Binds S)) (Splice S) deriving instance UniplateDirect (Rule S) (Splice S) deriving instance UniplateDirect (Binds S) (Splice S) deriving instance UniplateDirect (Alt S) (Splice S) deriving instance UniplateDirect (Stmt S) (Splice S) deriving instance UniplateDirect (FieldUpdate S) (Splice S) deriving instance UniplateDirect (QualStmt S) (Splice S) deriving instance UniplateDirect [QualStmt S] (Splice S) deriving instance UniplateDirect (Bracket S) (Splice S) deriving instance UniplateDirect (Pat S) (Bracket S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (Bracket S) deriving instance UniplateDirect (Maybe [InstDecl S]) (Bracket S) deriving instance UniplateDirect (Match S) (Bracket S) deriving instance UniplateDirect (Rhs S) (Bracket S) deriving instance UniplateDirect (Maybe (Binds S)) (Bracket S) deriving instance UniplateDirect (Rule S) (Bracket S) deriving instance UniplateDirect (Binds S) (Bracket S) deriving instance UniplateDirect (Alt S) (Bracket S) deriving instance UniplateDirect (Stmt S) (Bracket S) deriving instance UniplateDirect (FieldUpdate S) (Bracket S) deriving instance UniplateDirect (QualStmt S) (Bracket S) deriving instance UniplateDirect [QualStmt S] (Bracket S) deriving instance UniplateDirect (Splice S) (Bracket S) deriving instance UniplateDirect (ClassDecl S) (Splice S) deriving instance UniplateDirect (InstDecl S) (Splice S) deriving instance UniplateDirect (PatField S) (Splice S) deriving instance UniplateDirect (RPat S) (Splice S) deriving instance UniplateDirect (PXAttr S) (Splice S) deriving instance UniplateDirect (Maybe (Pat S)) (Splice S) deriving instance UniplateDirect (GuardedRhs S) (Splice S) deriving instance UniplateDirect (IPBind S) (Splice S) deriving instance UniplateDirect (GuardedAlts S) (Splice S) deriving instance UniplateDirect (PatField S) (Bracket S) deriving instance UniplateDirect (RPat S) (Bracket S) deriving instance UniplateDirect (PXAttr S) (Bracket S) deriving instance UniplateDirect (Maybe (Pat S)) (Bracket S) deriving instance UniplateDirect (ClassDecl S) (Bracket S) deriving instance UniplateDirect (InstDecl S) (Bracket S) deriving instance UniplateDirect (GuardedRhs S) (Bracket S) deriving instance UniplateDirect (IPBind S) (Bracket S) deriving instance UniplateDirect (GuardedAlts S) (Bracket S) deriving instance UniplateDirect (GuardedAlt S) (Splice S) deriving instance UniplateDirect (GuardedAlt S) (Bracket S) deriving instance UniplateDirect (Exp S) (Exp S) deriving instance UniplateDirect [Pat S] (Pat S) deriving instance UniplateDirect (Module S) (Name S) deriving instance UniplateDirect (Maybe (ModuleHead S)) (Name S) deriving instance UniplateDirect (OptionPragma S) (Name S) deriving instance UniplateDirect (ImportDecl S) (Name S) deriving instance UniplateDirect (ModuleHead S) (Name S) deriving instance UniplateDirect (Maybe (ImportSpecList S)) (Name S) deriving instance UniplateDirect (Maybe (ExportSpecList S)) (Name S) deriving instance UniplateDirect (ImportSpecList S) (Name S) deriving instance UniplateDirect (ExportSpecList S) (Name S) deriving instance UniplateDirect (ImportSpec S) (Name S) deriving instance UniplateDirect (ExportSpec S) (Name S) deriving instance UniplateDirect (CName S) (Name S) deriving instance UniplateDirect [Stmt S] (Exp S) deriving instance UniplateDirect (Decl S) (Type S) deriving instance UniplateDirect (Type S) deriving instance UniplateDirect (Maybe (Context S)) (Type S) deriving instance UniplateDirect (QualConDecl S) (Type S) deriving instance UniplateDirect (Maybe (Deriving S)) (Type S) deriving instance UniplateDirect (GadtDecl S) (Type S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (Type S) deriving instance UniplateDirect (InstHead S) (Type S) deriving instance UniplateDirect (Maybe [InstDecl S]) (Type S) deriving instance UniplateDirect (Exp S) (Type S) deriving instance UniplateDirect (Match S) (Type S) deriving instance UniplateDirect (Pat S) (Type S) deriving instance UniplateDirect (Maybe (Type S)) (Type S) deriving instance UniplateDirect (Rhs S) (Type S) deriving instance UniplateDirect (Maybe (Binds S)) (Type S) deriving instance UniplateDirect (Rule S) (Type S) deriving instance UniplateDirect (Context S) (Type S) deriving instance UniplateDirect (ConDecl S) (Type S) deriving instance UniplateDirect (Deriving S) (Type S) deriving instance UniplateDirect (ClassDecl S) (Type S) deriving instance UniplateDirect (InstDecl S) (Type S) deriving instance UniplateDirect (Binds S) (Type S) deriving instance UniplateDirect (Alt S) (Type S) deriving instance UniplateDirect (Stmt S) (Type S) deriving instance UniplateDirect (Maybe (Exp S)) (Type S) deriving instance UniplateDirect (FieldUpdate S) (Type S) deriving instance UniplateDirect (QualStmt S) (Type S) deriving instance UniplateDirect [QualStmt S] (Type S) deriving instance UniplateDirect (Bracket S) (Type S) deriving instance UniplateDirect (Splice S) (Type S) deriving instance UniplateDirect (XAttr S) (Type S) deriving instance UniplateDirect (PatField S) (Type S) deriving instance UniplateDirect (RPat S) (Type S) deriving instance UniplateDirect (PXAttr S) (Type S) deriving instance UniplateDirect (Maybe (Pat S)) (Type S) deriving instance UniplateDirect (GuardedRhs S) (Type S) deriving instance UniplateDirect (Maybe [RuleVar S]) (Type S) deriving instance UniplateDirect (Asst S) (Type S) deriving instance UniplateDirect (BangType S) (Type S) deriving instance UniplateDirect (FieldDecl S) (Type S) deriving instance UniplateDirect (IPBind S) (Type S) deriving instance UniplateDirect (GuardedAlts S) (Type S) deriving instance UniplateDirect (RuleVar S) (Type S) deriving instance UniplateDirect (GuardedAlt S) (Type S) deriving instance UniplateDirect (Exp S) (QName S) deriving instance UniplateDirect (QName S) deriving instance UniplateDirect (QOp S) (QName S) deriving instance UniplateDirect (Pat S) (QName S) deriving instance UniplateDirect (Binds S) (QName S) deriving instance UniplateDirect (Alt S) (QName S) deriving instance UniplateDirect (Stmt S) (QName S) deriving instance UniplateDirect (Maybe (Exp S)) (QName S) deriving instance UniplateDirect (FieldUpdate S) (QName S) deriving instance UniplateDirect (QualStmt S) (QName S) deriving instance UniplateDirect [QualStmt S] (QName S) deriving instance UniplateDirect (Type S) (QName S) deriving instance UniplateDirect (Bracket S) (QName S) deriving instance UniplateDirect (Splice S) (QName S) deriving instance UniplateDirect (XAttr S) (QName S) deriving instance UniplateDirect (PatField S) (QName S) deriving instance UniplateDirect (RPat S) (QName S) deriving instance UniplateDirect (PXAttr S) (QName S) deriving instance UniplateDirect (Maybe (Pat S)) (QName S) deriving instance UniplateDirect (Decl S) (QName S) deriving instance UniplateDirect (IPBind S) (QName S) deriving instance UniplateDirect (GuardedAlts S) (QName S) deriving instance UniplateDirect (Maybe (Binds S)) (QName S) deriving instance UniplateDirect (Maybe (Context S)) (QName S) deriving instance UniplateDirect (QualConDecl S) (QName S) deriving instance UniplateDirect (Maybe (Deriving S)) (QName S) deriving instance UniplateDirect (GadtDecl S) (QName S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (QName S) deriving instance UniplateDirect (InstHead S) (QName S) deriving instance UniplateDirect (Maybe [InstDecl S]) (QName S) deriving instance UniplateDirect (Match S) (QName S) deriving instance UniplateDirect (Maybe (Type S)) (QName S) deriving instance UniplateDirect (Rhs S) (QName S) deriving instance UniplateDirect (Rule S) (QName S) deriving instance UniplateDirect (GuardedAlt S) (QName S) deriving instance UniplateDirect (Context S) (QName S) deriving instance UniplateDirect (ConDecl S) (QName S) deriving instance UniplateDirect (Deriving S) (QName S) deriving instance UniplateDirect (ClassDecl S) (QName S) deriving instance UniplateDirect (InstDecl S) (QName S) deriving instance UniplateDirect (GuardedRhs S) (QName S) deriving instance UniplateDirect (Maybe [RuleVar S]) (QName S) deriving instance UniplateDirect (Asst S) (QName S) deriving instance UniplateDirect (BangType S) (QName S) deriving instance UniplateDirect (FieldDecl S) (QName S) deriving instance UniplateDirect (RuleVar S) (QName S) !-} hlint-1.9.35/src/HSE/Scope.hs0000644000000000000000000000732712726504430013744 0ustar0000000000000000 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 SrcSpanInfo) -> (Scope, QName SrcSpanInfo) -> 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 SrcSpanInfo) -> Scope -> QName SrcSpanInfo scopeMove (a, x) (Scope b) | isSpecial x = x | null imps = head $ real ++ [x] | any (not . importQualified) imps = unqual x | otherwise = Qual an (head $ mapMaybe importAs imps ++ map importModule imps) $ fromQual x where real = [Qual an (ModuleName an m) $ fromQual x | m <- possModules a x] imps = [i | r <- real, i <- b, possImport i r] -- 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-1.9.35/src/HSE/Match.hs0000644000000000000000000001112612726504430013717 0ustar0000000000000000{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-} module HSE.Match( View(..), Named(..), (~=), isSym, App2(..), PVar_(..), Var_(..), PApp_(..) ) where import Data.Char import HSE.Type import HSE.Util import qualified Language.Haskell.Exts as HSE_ 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 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 HSE_.QName where fromNamed (HSE_.Special HSE_.Cons) = ":" fromNamed (HSE_.Special HSE_.UnitCon) = "()" fromNamed (HSE_.UnQual x) = fromNamed x fromNamed _ = "" toNamed ":" = HSE_.Special HSE_.Cons toNamed x = HSE_.UnQual $ 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 HSE_.Name where fromNamed (HSE_.Ident x) = x fromNamed (HSE_.Symbol x) = x toNamed x | isSym x = HSE_.Symbol x | otherwise = HSE_.Ident 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-1.9.35/src/HSE/FreeVars.hs0000644000000000000000000001156112726504430014403 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} module HSE.FreeVars(FreeVars, freeVars, vars, varss, pvars) where import Data.Monoid import HSE.Type as HSE import qualified Data.Set as Set import Data.Set(Set) import Prelude vars x = Set.toList $ freeVars x varss x = Set.toList $ free $ allVars x pvars x = Set.toList $ bound $ allVars x (^+) = Set.union (^-) = Set.difference data Vars = Vars {bound :: Set String, free :: Set String} instance Monoid Vars where mempty = Vars Set.empty Set.empty mappend (Vars x1 x2) (Vars y1 y2) = Vars (x1 ^+ y1) (x2 ^+ y2) mconcat fvs = Vars (Set.unions $ map bound fvs) (Set.unions $ map free fvs) class AllVars a where -- | Return the variables, erring on the side of more free variables allVars :: a -> Vars class FreeVars a where -- | Return the variables, erring on the side of more free variables freeVars :: a -> Set String freeVars_ :: FreeVars a => a -> Vars freeVars_ = Vars Set.empty . freeVars inFree :: (AllVars a, FreeVars b) => a -> b -> Set String inFree a b = free aa ^+ (freeVars b ^- bound aa) where aa = allVars a inVars :: (AllVars a, AllVars b) => a -> b -> Vars inVars a b = Vars (bound aa ^+ bound bb) (free aa ^+ (free bb ^- bound aa)) where aa = allVars a bb = allVars b unqualNames :: QName S -> [String] unqualNames (UnQual _ x) = [prettyPrint x] unqualNames _ = [] unqualOp :: QOp S -> [String] unqualOp (QVarOp _ x) = unqualNames x unqualOp (QConOp _ x) = unqualNames x instance FreeVars (Set String) where freeVars = id instance AllVars Vars where allVars = id instance FreeVars Exp_ where -- never has any bound variables freeVars (Var _ x) = Set.fromList $ unqualNames x freeVars (VarQuote l x) = freeVars $ Var l x freeVars (SpliceExp _ (IdSplice _ x)) = Set.fromList [x] freeVars (InfixApp _ a op b) = freeVars a ^+ Set.fromList (unqualOp op) ^+ freeVars b freeVars (LeftSection _ a op) = freeVars a ^+ Set.fromList (unqualOp op) freeVars (RightSection _ op b) = Set.fromList (unqualOp op) ^+ freeVars b freeVars (Lambda _ p x) = inFree p x freeVars (Let _ bind x) = inFree bind x freeVars (Case _ x alts) = freeVars x `mappend` freeVars alts freeVars (Do _ xs) = free $ allVars xs freeVars (MDo l xs) = freeVars $ Do l xs freeVars (ParComp _ x xs) = free xfv ^+ (freeVars x ^- bound xfv) where xfv = mconcat $ map allVars xs freeVars (ListComp l x xs) = freeVars $ ParComp l x [xs] freeVars x = freeVars $ children x instance FreeVars [Exp_] where freeVars = Set.unions . map freeVars instance AllVars Pat_ where allVars (PVar _ x) = Vars (Set.singleton $ prettyPrint x) Set.empty allVars (PNPlusK l x _) = allVars (PVar l x) allVars (PAsPat l n x) = allVars (PVar l n) `mappend` allVars x allVars (PWildCard _) = mempty -- explicitly cannot guess what might be bound here allVars (PViewPat _ e p) = freeVars_ e `mappend` allVars p allVars x = allVars $ children x instance AllVars [Pat_] where allVars = mconcat . map allVars instance FreeVars (HSE.Alt S) where freeVars (HSE.Alt _ pat alt bind) = inFree pat $ inFree bind alt instance FreeVars [HSE.Alt S] where freeVars = mconcat . map freeVars instance FreeVars (Rhs S) where freeVars (UnGuardedRhs _ x) = freeVars x freeVars (GuardedRhss _ xs) = mconcat $ map freeVars xs instance FreeVars (GuardedRhs S) where freeVars (GuardedRhs _ stmt exp) = inFree stmt exp instance AllVars (QualStmt S) where allVars (QualStmt _ x) = allVars x allVars x = freeVars_ (childrenBi x :: [Exp_]) instance AllVars [QualStmt S] where allVars (x:xs) = inVars x xs allVars [] = mempty instance AllVars [Stmt S] where allVars (x:xs) = inVars x xs allVars [] = mempty instance AllVars (Stmt S) where allVars (Generator _ pat exp) = allVars pat `mappend` freeVars_ exp allVars (Qualifier _ exp) = freeVars_ exp allVars (LetStmt _ binds) = allVars binds allVars (RecStmt _ stmts) = allVars stmts instance AllVars (Maybe (Binds S)) where allVars = maybe mempty allVars instance AllVars (Binds S) where allVars (BDecls _ decls) = allVars decls allVars (IPBinds _ binds) = freeVars_ binds instance AllVars [Decl S] where allVars = mconcat . map allVars instance AllVars (Decl S) where allVars (FunBind _ m) = allVars m allVars (PatBind _ pat rhs bind) = allVars pat `mappend` freeVars_ (inFree bind rhs) allVars _ = mempty instance AllVars [Match S] where allVars = mconcat . map allVars instance AllVars (Match S) where allVars (Match l name pat rhs binds) = allVars (PVar l name) `mappend` freeVars_ (inFree pat (inFree binds rhs)) allVars (InfixMatch l p1 name p2 rhs binds) = allVars $ Match l name (p1:p2) rhs binds instance FreeVars [IPBind S] where freeVars = mconcat . map freeVars instance FreeVars (IPBind S) where freeVars (IPBind _ _ exp) = freeVars exp hlint-1.9.35/src/HSE/Evaluate.hs0000644000000000000000000000156212726504430014434 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} -- Evaluate a HSE Exp as much as possible module HSE.Evaluate(evaluate) where import HSE.Match import HSE.Util import HSE.Type import HSE.Bracket evaluate :: Exp_ -> Exp_ evaluate = fromParen . transform evaluate1 evaluate1 :: Exp_ -> Exp_ evaluate1 (App s len (Lit _ (String _ xs _))) | len ~= "length" = Lit s $ Int s n (show n) where n = fromIntegral $ length xs evaluate1 (App s len (List _ xs)) | len ~= "length" = Lit s $ Int s n (show n) where n = fromIntegral $ length xs evaluate1 (view -> App2 op (Lit _ x) (Lit _ y)) | op ~= "==" = toNamed $ show $ x =~= y evaluate1 (view -> App2 op (Lit _ (Int _ x _)) (Lit _ (Int _ y _))) | op ~= ">=" = toNamed $ show $ x >= y evaluate1 (view -> App2 op x y) | op ~= "&&" && x ~= "True" = y | op ~= "&&" && x ~= "False" = x evaluate1 (Paren _ x) | isAtom x = x evaluate1 x = x hlint-1.9.35/src/HSE/Bracket.hs0000644000000000000000000001064512726504430014243 0ustar0000000000000000{-# LANGUAGE PatternGuards, TypeSynonymInstances, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-overlapping-patterns -fno-warn-incomplete-patterns #-} module HSE.Bracket( Brackets(..), paren, transformBracket, rebracket1, appsBracket ) where import HSE.Type import HSE.Util import Util class Brackets a where remParen :: a -> Maybe a -- remove one paren, or Nothing if there is no paren addParen :: a -> a -- write out a paren -- | Is this item lexically requiring no bracketing ever -- i.e. is totally atomic isAtom :: a -> Bool -- | Is the child safe free from brackets in the parent position. -- Err on the side of caution, True = don't know needBracket :: Int -> a -> a -> Bool instance Brackets Exp_ where remParen (Paren _ x) = Just x remParen _ = Nothing addParen = Paren an isAtom x = case x of Paren{} -> True Tuple{} -> True List{} -> True LeftSection{} -> True RightSection{} -> True TupleSection{} -> True RecConstr{} -> True ListComp{} -> True EnumFrom{} -> True EnumFromTo{} -> True EnumFromThen{} -> True EnumFromThenTo{} -> True _ -> isLexeme x -- note: i is the index in children, not in the AST needBracket i parent child | isAtom child = False | InfixApp{} <- parent, App{} <- child = False | isSection parent, App{} <- child = False | Let{} <- parent, App{} <- child = False | ListComp{} <- parent = False | List{} <- parent = False | Tuple{} <- parent = False | If{} <- parent, isAnyApp child = False | App{} <- parent, i == 0, App{} <- child = False | ExpTypeSig{} <- parent, i == 0, isApp child = False | Paren{} <- parent = False | isDotApp parent, isDotApp child, i == 1 = False | RecConstr{} <- parent = False | RecUpdate{} <- parent, i /= 0 = False | Case{} <- parent, i /= 0 || isAnyApp child = False | Lambda{} <- parent, i == length (universeBi parent :: [Pat_]) - 1 = False -- watch out for PViewPat | Do{} <- parent = False | otherwise = True instance Brackets Type_ where remParen (TyParen _ x) = Just x remParen _ = Nothing addParen = TyParen an isAtom x = case x of TyParen{} -> True TyTuple{} -> True TyList{} -> True TyVar{} -> True TyCon{} -> True _ -> False needBracket i parent child | isAtom child = False -- a -> (b -> c) is not a required bracket, but useful for documentation about arity etc. -- | TyFun{} <- parent, i == 1, TyFun{} <- child = False | TyFun{} <- parent, TyApp{} <- child = False | TyTuple{} <- parent = False | TyList{} <- parent = False | TyInfix{} <- parent, TyApp{} <- child = False | TyParen{} <- parent = False | otherwise = True instance Brackets Pat_ where remParen (PParen _ x) = Just x remParen _ = Nothing addParen = PParen an isAtom x = case x of PParen{} -> True PTuple{} -> True PList{} -> True PRec{} -> True PVar{} -> True PApp _ _ [] -> True PWildCard{} -> True _ -> False needBracket i parent child | isAtom child = False | PTuple{} <- parent = False | PList{} <- parent = False | PInfixApp{} <- parent, PApp{} <- child = False | PParen{} <- parent = False | otherwise = True -- | Add a Paren around something if it is not atomic paren :: Exp_ -> Exp_ paren x = if isAtom x then x else addParen x -- | Descend, and if something changes then add/remove brackets appropriately descendBracket :: (Exp_ -> (Bool, Exp_)) -> Exp_ -> Exp_ descendBracket op x = descendIndex g x where g i y = if a then f i b else b where (a,b) = op y f i (Paren _ y) | not $ needBracket i x y = y f i y | needBracket i x y = addParen y f i y = y transformBracket :: (Exp_ -> Maybe Exp_) -> Exp_ -> Exp_ transformBracket op = snd . g where g = f . descendBracket g f x = maybe (False,x) ((,) True) (op x) -- | Add/remove brackets as suggested needBracket at 1-level of depth rebracket1 :: Exp_ -> Exp_ rebracket1 = descendBracket (\x -> (True,x)) -- a list of application, with any necessary brackets appsBracket :: [Exp_] -> Exp_ appsBracket = foldl1 (\x -> rebracket1 . App an x) hlint-1.9.35/src/HSE/All.hs0000644000000000000000000001360212726504430013374 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} module HSE.All( module X, ParseFlags(..), defaultParseFlags, parseFlagsAddFixities, parseFlagsSetLanguage, parseModuleEx, ParseError(..) ) where import HSE.Util as X import HSE.Evaluate as X import HSE.Type as X import HSE.Bracket as X import HSE.Match as X import HSE.Scope as X import HSE.FreeVars as X import Util import CmdLine import Data.Char import Data.List.Extra import Data.Maybe import Language.Preprocessor.Cpphs import qualified Data.Map as Map import System.IO import Data.Functor import Prelude -- | Created with 'defaultParseFlags', used by 'parseModuleEx'. data ParseFlags = ParseFlags {encoding :: TextEncoding -- ^ How the file is read in (defaults to 'utf8'). ,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 utf8 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}} 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 <- maybe (readFileEncoding' (encoding flags) file) return str 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 || a1 == AssocNone) = o -- Ambiguous infix expression! | p1 > p2 || p1 == p2 && (a1 == AssocLeft || a2 == AssocNone) = 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 x, s /= ""] hlint-1.9.35/src/Hint/0000755000000000000000000000000012726504430012611 5ustar0000000000000000hlint-1.9.35/src/Hint/Util.hs0000644000000000000000000001050212726504430014060 0ustar0000000000000000{-# 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 . toSrcSpan $ 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 . toSrcSpan $ 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-1.9.35/src/Hint/Unsafe.hs0000644000000000000000000000374312726504430014375 0ustar0000000000000000 {- 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" (toSrcSpan $ 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-1.9.35/src/Hint/Type.hs0000644000000000000000000000243312726504430014070 0ustar0000000000000000module Hint.Type(module Hint.Type, module Export) where import Data.Monoid 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 = Hint {hintModules :: [(Scope, Module SrcSpanInfo)] -> [Idea] -- ^ Given a list of modules (and their scope information) generate some 'Idea's. ,hintModule :: Scope -> Module SrcSpanInfo -> [Idea] -- ^ Given a single module and its scope information generate some 'Idea's. ,hintDecl :: 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 :: Comment -> [Idea] -- ^ Given a comment generate some 'Idea's. } instance Monoid Hint where mempty = Hint (const []) (\_ _ -> []) (\_ _ _ -> []) (const []) mappend (Hint x1 x2 x3 x4) (Hint y1 y2 y3 y4) = Hint (\a -> x1 a ++ y1 a) (\a b -> x2 a b ++ y2 a b) (\a b c -> x3 a b c ++ y3 a b c) (\a -> x4 a ++ y4 a) hlint-1.9.35/src/Hint/Pragma.hs0000644000000000000000000001005312726504430014353 0ustar0000000000000000{-# 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 (toSrcSpan . ann $ old) (prettyPrint old) (Just $ prettyPrint new) [] [ModifyComment (toSS old) (prettyPrint new)] MultiComment repl delete new -> mkIdea (toSrcSpan . ann $ repl) (f [repl, delete]) (Just $ prettyPrint new) [] [ ModifyComment (toSS repl) (prettyPrint new) , ModifyComment (toSS delete) ""] OptionsToComment old new r -> mkIdea (toSrcSpan . 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-1.9.35/src/Hint/Pattern.hs0000644000000000000000000002001012726504430014553 0ustar0000000000000000{-# 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 -- yes x 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 -} 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 . toSrcSpan $ 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 SrcSpanInfo 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 _ = 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-1.9.35/src/Hint/Naming.hs0000644000000000000000000000637312726504430014367 0ustar0000000000000000{-# 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.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 $ UnQual an $ Ident an "..." -- Must be an Ident, not a Symbol 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 :: Biplate a (Name S) => [(String,String)] -> a -> a replaceNames rep = descendBi f where f (Ident _ x) = Ident an $ fromMaybe x $ lookup x rep f x = x hlint-1.9.35/src/Hint/Monad.hs0000644000000000000000000001214012726504430014201 0ustar0000000000000000{-# 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 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 yes = mapM async ds >>= mapM wait >> return () -- mapM async ds >>= mapM_ wait -} 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) $ universeBi d monadExp :: Decl_ -> Exp_ -> [Idea] monadExp decl x = case x of (view -> App2 op x1 x2) | 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]] ++ [suggest "Use let" x (Do an y) rs | Just (y, rs) <- [monadLet xs]] ++ concat [f x | Qualifier _ x <- init xs] _ -> [] where f x = [warn ("Use " ++ name) x y r | Just (name,y, r) <- [monadCall x], fromNamed decl /= name] 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-1.9.35/src/Hint/Match.hs0000644000000000000000000002760412726504430014212 0ustar0000000000000000{-# LANGUAGE PatternGuards, ViewPatterns, RelaxedPolyRec, RecordWildCards, FlexibleContexts, ScopedTypeVariables, TupleSections #-} {- 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 Data.Data import Unsafe.Coerce import Settings import Hint.Type import Control.Monad import Data.Tuple.Extra import Util 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, rule) <- [matchIdea s decl m parent x] , let r = R.Replace R.Expr (toSS x) subst (prettyPrint rule) ] matchIdea :: Scope -> Decl_ -> HintRule -> Maybe (Int, Exp_) -> Exp_ -> Maybe (Exp_,[Note], [(String, R.SrcSpan)], Exp_) matchIdea s decl HintRule{..} parent x = do let nm a b = scopeMatch (hintRuleScope,a) (s,b) u <- unifyExp nm True hintRuleLHS x u <- check u -- need to check free vars before unqualification, but after subst (with e) -- need to unqualify before substitution (with res) let e = subst u hintRuleRHS template = substT u hintRuleRHS res = addBracket parent $ performEval $ subst u $ unqualify hintRuleScope s u 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) : u guard $ checkDefine decl parent res return (res,hintRuleNotes, [(s, toSS pos) | (s, pos) <- u, ann pos /= an], template) -- | Descend, and if something changes then add/remove brackets appropriately in both the template -- and the original expression. descendBracketTemplate :: (Exp_ -> (Bool, (Exp_, Exp_))) -> Exp_ -> Exp_ descendBracketTemplate op x = descendIndex g x where g i y = if a then f i b else fst b where (a, b) = op y f i (v, y) | needBracket i x y = addParen v f i (v, y) = v transformBracketTemplate :: (Exp_ -> Maybe (Exp_, Exp_)) -> Exp_ -> Exp_ transformBracketTemplate op = fst . snd . g where g :: Exp_ -> (Bool, (Exp_, Exp_)) g = f . descendBracketTemplate g f :: Exp_ -> (Bool, (Exp_, Exp_)) f x = maybe (False,(x, x)) ((,) True) (op x) -- perform a substitution substT :: [(String,Exp_)] -> Exp_ -> Exp_ substT bind = transform g . transformBracketTemplate f where f v@(Var _ (fromNamed -> x)) | isUnifyVar x = case lookup x bind of Just x -> if ann x == an then Just (x, x) else Just (v, x) Nothing -> Nothing f _ = Nothing g (App _ np x) | np ~= "_noParen_" = fromParen x g x = x --------------------------------------------------------------------- -- 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 -- unify a b = c, a[c] = b unify :: Data a => NameMatch -> Bool -> a -> a -> Maybe [(String,Exp_)] unify nm root x y | Just x <- cast x = unifyExp nm root x (unsafeCoerce y) | Just x <- cast x = unifyPat nm x (unsafeCoerce y) | Just (x :: SrcSpanInfo) <- cast x = Just [] | otherwise = unifyDef nm x y unifyDef :: Data a => NameMatch -> a -> a -> Maybe [(String,Exp_)] unifyDef nm x y = fmap concat . 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 [(String,Exp_)] unifyExp nm root x y | isParen x || isParen y = map (rebracket y) <$> unifyExp nm root (fromParen x) (fromParen y) unifyExp nm root (Var _ (fromNamed -> v)) y | isUnifyVar v = Just [(v,y)] unifyExp nm root (Var _ x) (Var _ y) | nm x y = Just [] 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; InfixApp _ y11 dot y12 <- return $ fromParen y1; guard $ isDot dot; unifyExp nm root x (App an y11 (App an y12 y2))) 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 unifyExp nm root _ _ = Nothing rebracket (Paren l e') (v, e) | e' == e = (v, Paren l e) rebracket e (v, e') = (v, e') unifyPat :: NameMatch -> Pat_ -> Pat_ -> Maybe [(String,Exp_)] unifyPat nm (PVar _ x) (PVar _ y) = Just [(fromNamed x, toNamed $ fromNamed y)] unifyPat nm (PVar _ x) PWildCard{} = Just [(fromNamed x, toNamed $ "_" ++ fromNamed x)] unifyPat nm x y = unifyDef nm x y -- types that are not already handled in unify {-# INLINE isOther #-} isOther Var{} = False isOther App{} = False isOther InfixApp{} = False isOther _ = True --------------------------------------------------------------------- -- SUBSTITUTION UTILITIES -- check the unification is valid check :: [(String,Exp_)] -> Maybe [(String,Exp_)] check = mapM f . groupSort where f (x,ys) = if checkSame ys then Just (x,head ys) else Nothing checkSame [] = True checkSame (x:xs) = all (x =~=) xs -- perform a substitution subst :: [(String,Exp_)] -> Exp_ -> Exp_ subst bind = transform g . transformBracket f where f (Var _ (fromNamed -> x)) | isUnifyVar x = lookup x bind f _ = Nothing g (App _ np x) | np ~= "_noParen_" = fromParen x g x = x --------------------------------------------------------------------- -- 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 performEval :: Exp_ -> Exp_ performEval (App _ e x) | e ~= "_eval_" = evaluate x performEval x = x -- contract Data.List.foo ==> foo, if Data.List is loaded -- change X.foo => Module.foo, where X is looked up in the subst unqualify :: Scope -> Scope -> [(String,Exp_)] -> Exp_ -> Exp_ unqualify from to subs = transformBi f where f (Qual _ (ModuleName _ [m]) x) | Just y <- fromNamed <$> lookup [m] subs = if null y then UnQual an x else Qual an (ModuleName an y) x 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-1.9.35/src/Hint/ListRec.hs0000644000000000000000000001351612726504430014520 0ustar0000000000000000{-# 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-1.9.35/src/Hint/List.hs0000644000000000000000000001071312726504430014062 0ustar0000000000000000{-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts, TupleSections #-} {- 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 -} module Hint.List(listHint) where import Control.Applicative import Hint.Type 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) -- 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 toSS = toRefactSrcSpan . toSrcSpan . ann rs = [Replace Type (toSS t) [] (prettyPrint typeString) | t <- universe x, t =~= typeListChar] hlint-1.9.35/src/Hint/Lambda.hs0000644000000000000000000001417612726504430014336 0ustar0000000000000000{-# 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 +)) -- (+) -} 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 loc [Match _ name pats (UnGuardedRhs _ 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] 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 _ = [] 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 _ _ = [] -- 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-1.9.35/src/Hint/Import.hs0000644000000000000000000001555212726504430014427 0ustar0000000000000000{-# 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_) module Foo(module A, baz, module B, module C) where; import A; import D; import B(map,filter); import C \ -- module Foo(baz, module X) where; import A as X; import B as X(map, filter); import C as X module Foo(module A, baz, module B, module X) where; import A; import B; import X \ -- module Foo(baz, module Y) where; import A as Y; import B as Y; import X as Y -} module Hint.Import(importHint) where import Control.Applicative import Control.Arrow import Hint.Type import Refact.Types hiding (ModuleName) import qualified Refact.Types as R import Data.List.Extra import Data.Maybe import Prelude importHint :: ModuHint importHint _ x = concatMap (wrap . snd) (groupSort [((fromNamed $ importModule i,importPkg i),i) | i <- universeBi x, not $ importSrc i]) ++ concatMap (\x -> hierarchy x ++ reduce1 x) (universeBi x) ++ multiExport x wrap :: [ImportDecl S] -> [Idea] wrap o = [ rawIdea Warning "Use fewer imports" (toSrcSpan $ 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 $ fromMaybe (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 reduce x y of Nothing -> first (y:) <$> simplifyHead x ys Just (xy, rs) -> Just (xy : ys, rs) reduce :: ImportDecl S -> ImportDecl S -> Maybe (ImportDecl S, [Refactoring R.SrcSpan]) reduce 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 reduce _ _ = Nothing reduce1 :: ImportDecl S -> [Idea] reduce1 i@ImportDecl{..} | Just (dropAnn importModule) == fmap dropAnn importAs = [suggest "Redundant as" i i{importAs=Nothing} [RemoveAsKeyword (toSS i)]] reduce1 _ = [] 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" (toSrcSpan $ 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 multiExport :: Module S -> [Idea] multiExport x = [ rawIdeaN Suggestion "Use import/export shortcut" (toSrcSpan $ ann hd) (unlines $ prettyPrint hd : map prettyPrint imps) (Just $ unlines $ prettyPrint newhd : map prettyPrint newimps) [] | Module l (Just hd) _ imp _ <- [x] , let asNames = mapMaybe importAs imp , let expNames = [x | EModuleContents _ x <- childrenBi hd] , let imps = [i | i@ImportDecl{importAs=Nothing,importQualified=False,importModule=name} <- imp ,name `notElem_` asNames, name `elem_` expNames] , length imps >= 3 , let newname = ModuleName an $ head $ map return ("XYZ" ++ ['A'..]) \\ [x | ModuleName (_ :: S) x <- universeBi hd ++ universeBi imp] , let reexport (EModuleContents _ x) = x `notElem_` map importModule imps reexport x = True , let newhd = descendBi (\xs -> filter reexport xs ++ [EModuleContents an newname]) hd , let newimps = [i{importAs=Just newname} | i <- imps] ] hlint-1.9.35/src/Hint/Extensions.hs0000644000000000000000000001732612726504430015315 0ustar0000000000000000{- 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 -} module Hint.Extensions(extensionsHint) where import Hint.Type import Data.Maybe import Data.List.Extra import Refact.Types extensionsHint :: ModuHint extensionsHint _ x = [rawIdea Warning "Unused LANGUAGE pragma" (toSrcSpan 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 _ _ = [] -- | Classes that don't work with newtype deriving noNewtypeDeriving :: [String] noNewtypeDeriving = ["Read","Show","Data","Typeable","Generic","Generic1"] usedExt :: Extension -> Module_ -> Bool usedExt (EnableExtension x) = used x 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 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 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` noNewtypeDeriving) . fst . derives 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 -- 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) $ new ++ dat where (new,dat) = derives m -- | 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_ -> ([String],[String]) derives m = concatUnzip $ map decl (childrenBi m) ++ map idecl (childrenBi m) where idecl :: InstDecl S -> ([String], [String]) idecl (InsData _ dn _ _ ds) = g dn ds idecl (InsGData _ dn _ _ _ ds) = g dn ds idecl _ = ([], []) decl :: Decl_ -> ([String], [String]) 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) = (xs, xs) -- don't know whether this was on newtype or not where xs = [ir hd] decl _ = ([], []) g dn ds = if isNewType dn then (xs,[]) else ([],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 (&) f g x = f x || g x hasT t x = not $ null (universeBi x `asTypeOf` [t]) hasT2 ~(t1,t2) = hasT t1 & hasT t2 hasS :: Biplate x (f S) => (f S -> Bool) -> x -> Bool hasS test = any test . universeBi has f = any f . universeBi hlint-1.9.35/src/Hint/Duplicate.hs0000644000000000000000000000517012726504430015062 0ustar0000000000000000{-# 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 (toSrcSpan . 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 nullSrcSpan 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-1.9.35/src/Hint/Comment.hs0000644000000000000000000000223312726504430014547 0ustar0000000000000000 {- {- 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-1.9.35/src/Hint/Bracket.hs0000644000000000000000000001237212726504430014525 0ustar0000000000000000{-# 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)) -- @Warning (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) 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 bracket :: (Data (a S), Uniplate (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), Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => Maybe (Int,a S,a S -> a S) -> a S -> [Idea] f Just{} o@(remParen -> Just x) | isAtom x = bracketError msg o x : g x f Nothing o@(remParen -> Just x) | bad || isAtom x = (if isAtom x then bracketError else bracketWarning) msg o x : g x f (Just (i,o,gen)) v@(remParen -> 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), Uniplate (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-1.9.35/src/Hint/All.hs0000644000000000000000000000406012726504430013655 0ustar0000000000000000 module Hint.All( Hint(..), HintBuiltin(..), DeclHint, ModuHint, resolveHints, hintRules, builtinHints ) where import Data.Monoid import Settings 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.Pragma import Hint.Extensions import Hint.Duplicate import Hint.Comment import Hint.Unsafe -- | 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 | HintPragma | HintExtensions | HintUnsafe | HintDuplicate | HintComment 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 HintPragma -> modu pragmaHint HintExtensions -> modu extensionsHint HintUnsafe -> modu unsafeHint HintDuplicate -> mods duplicateHint HintComment -> comm commentHint where decl x = mempty{hintDecl=x} modu x = mempty{hintModule=x} mods x = mempty{hintModules=x} comm x = mempty{hintComment=x} -- | A list of builtin hints, currently including entries such as @\"List\"@ and @\"Bracket\"@. builtinHints :: [(String, Hint)] builtinHints = [(drop 4 $ show h, resolveHints [Left h]) | h <- [minBound .. maxBound]] -- | Transform a list of 'HintRule' into a 'Hint'. resolveHints :: [Either HintBuiltin HintRule] -> Hint resolveHints xs = mconcat $ mempty{hintDecl=readMatch rights} : map builtin (nub lefts) where (lefts,rights) = partitionEithers xs hintRules :: [HintRule] -> Hint hintRules = resolveHints . map Right hlint-1.9.35/data/0000755000000000000000000000000012726504430012031 5ustar0000000000000000hlint-1.9.35/data/Test.hs0000644000000000000000000000604412726504430013310 0ustar0000000000000000-- 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 import "hint" HLint.Builtin.All 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 module "HLint: ignore Use import/export shortcut" #-} \ module ABCD(module A, module B, module C) where \ import A; import B; import C -- @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-1.9.35/data/report_template.html0000644000000000000000000000656712726504430016143 0ustar0000000000000000 HLint Report

    All hints

      $HINTS

    All files

      $FILES

    Report generated by HLint $VERSION - a tool to suggest improvements to your Haskell code.

    $CONTENT
    hlint-1.9.35/data/hs-lint.el0000644000000000000000000000762312726504430013741 0ustar0000000000000000;;; hs-lint.el --- minor mode for HLint code checking ;; Copyright 2009 (C) Alex Ott ;; ;; Author: Alex Ott ;; Keywords: haskell, lint, HLint ;; Requirements: ;; Status: distributed under terms of GPL2 or above ;; Typical message from HLint looks like: ;; ;; /Users/ott/projects/lang-exp/haskell/test.hs:52:1: Eta reduce ;; Found: ;; count1 p l = length (filter p l) ;; Why not: ;; count1 p = length . filter p (require 'compile) (defgroup hs-lint nil "Run HLint as inferior of Emacs, parse error messages." :group 'tools :group 'haskell) (defcustom hs-lint-command "hlint" "The default hs-lint command for \\[hlint]." :type 'string :group 'hs-lint) (defcustom hs-lint-save-files t "Save modified files when run HLint or no (ask user)" :type 'boolean :group 'hs-lint) (defcustom hs-lint-replace-with-suggestions nil "Replace user's code with suggested replacements" :type 'boolean :group 'hs-lint) (defcustom hs-lint-replace-without-ask nil "Replace user's code with suggested replacements automatically" :type 'boolean :group 'hs-lint) (defun hs-lint-process-setup () "Setup compilation variables and buffer for `hlint'." (run-hooks 'hs-lint-setup-hook)) ;; regex for replace suggestions ;; ;; ^\(.*?\):\([0-9]+\):\([0-9]+\): .* ;; Found: ;; \s +\(.*\) ;; Why not: ;; \s +\(.*\) (defvar hs-lint-regex "^\\(.*?\\):\\([0-9]+\\):\\([0-9]+\\): .*[\n\C-m]Found:[\n\C-m]\\s +\\(.*\\)[\n\C-m]Why not:[\n\C-m]\\s +\\(.*\\)[\n\C-m]" "Regex for HLint messages") (defun make-short-string (str maxlen) (if (< (length str) maxlen) str (concat (substring str 0 (- maxlen 3)) "..."))) (defun hs-lint-replace-suggestions () "Perform actual replacement of suggestions" (goto-char (point-min)) (while (re-search-forward hs-lint-regex nil t) (let* ((fname (match-string 1)) (fline (string-to-number (match-string 2))) (old-code (match-string 4)) (new-code (match-string 5)) (msg (concat "Replace '" (make-short-string old-code 30) "' with '" (make-short-string new-code 30) "'")) (bline 0) (eline 0) (spos 0) (new-old-code "")) (save-excursion (switch-to-buffer (get-file-buffer fname)) (goto-line fline) (beginning-of-line) (setf bline (point)) (when (or hs-lint-replace-without-ask (yes-or-no-p msg)) (end-of-line) (setf eline (point)) (beginning-of-line) (setf old-code (regexp-quote old-code)) (while (string-match "\\\\ " old-code spos) (setf new-old-code (concat new-old-code (substring old-code spos (match-beginning 0)) "\\ *")) (setf spos (match-end 0))) (setf new-old-code (concat new-old-code (substring old-code spos))) (remove-text-properties bline eline '(composition nil)) (when (re-search-forward new-old-code eline t) (replace-match new-code nil t))))))) (defun hs-lint-finish-hook (buf msg) "Function, that is executed at the end of HLint execution" (if hs-lint-replace-with-suggestions (hs-lint-replace-suggestions) (next-error 1 t))) (define-compilation-mode hs-lint-mode "HLint" "Mode for check Haskell source code." (set (make-local-variable 'compilation-process-setup-function) 'hs-lint-process-setup) (set (make-local-variable 'compilation-disable-input) t) (set (make-local-variable 'compilation-scroll-output) nil) (set (make-local-variable 'compilation-finish-functions) (list 'hs-lint-finish-hook)) ) (defun hs-lint () "Run HLint for current buffer with haskell source" (interactive) (save-some-buffers hs-lint-save-files) (compilation-start (concat hs-lint-command " \"" buffer-file-name "\"") 'hs-lint-mode)) (provide 'hs-lint) ;;; hs-lint.el ends here hlint-1.9.35/data/HLint_TypeCheck.hs0000644000000000000000000000050512726504430015342 0ustar0000000000000000 -- Used with --typecheck module HLint_TypeCheck where (==>) :: a -> a -> a (==>) = undefined _noParen_ = id _eval_ = id --------------------------------------------------------------------- -- EXAMPLES main :: IO () main = return () {-# LINE 116 "data\\Default.hs" #-} _test64 = \ p x -> (and (map p x)) ==> (all p x) hlint-1.9.35/data/HLint_QuickCheck.hs0000644000000000000000000001125012726504430015474 0ustar0000000000000000{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules, ScopedTypeVariables, DeriveDataTypeable, ViewPatterns #-} {-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} -- | Used with --quickcheck module HLint_QuickCheck(module HLint_QuickCheck, module X) where import System.IO.Unsafe import Data.Typeable import Data.List import Data.Maybe import Data.IORef import Control.Exception import Control.Monad import System.IO import Control.Concurrent.Chan import System.Mem.Weak(Weak) import Test.QuickCheck hiding ((==>)) import Test.QuickCheck.Test hiding (test) import Test.QuickCheck.Modifiers as X default(Maybe Bool,[Bool],Int,Dbl) -- We need a Show instance that nails down the sides, so defaulting works. -- The one from Text.Show.Functions is insufficient. instance (Show a, Show b) => Show (a -> b) where show _ = "" newtype Dbl = Dbl Double deriving (Enum,Floating,Fractional,Num,Read,Real,RealFloat,RealFrac,Show,Typeable,Arbitrary,CoArbitrary) instance Eq Dbl where Dbl a == Dbl b | isNaN a && isNaN b = True | otherwise = abs (a - b) < 1e-4 || let s = a+b in s /= 0 && abs ((a-b)/s) < 1e-8 instance Ord Dbl where compare a b | a == b = EQ compare (Dbl a) (Dbl b) = compare a b newtype NegZero a = NegZero a deriving (Typeable, Show) instance (Num a, Arbitrary a) => Arbitrary (NegZero a) where arbitrary = fmap (NegZero . negate . abs) arbitrary newtype Nat a = Nat a deriving (Typeable, Show) instance (Num a, Arbitrary a) => Arbitrary (Nat a) where arbitrary = fmap (Nat . abs) arbitrary newtype Compare a = Compare (a -> a -> Ordering) deriving (Typeable, Show) instance (Ord a, Arbitrary a) => Arbitrary (Compare a) where arbitrary = fmap (\b -> Compare $ (if b then flip else id) compare) arbitrary instance Show a => Show (IO a) where show _ = "" instance Show a => Show (Weak a) where show _ = "" instance Show a => Show (Chan a) where show _ = "" instance Eq (IO a) where _ == _ = True instance Eq SomeException where a == b = show a == show b deriving instance Typeable IOMode instance Arbitrary Handle where arbitrary = elements [stdin, stdout, stderr] instance CoArbitrary Handle where coarbitrary _ = variant 0 instance Arbitrary IOMode where arbitrary = elements [ReadMode,WriteMode,AppendMode,ReadWriteMode] instance Arbitrary a => Arbitrary (IO a) where arbitrary = fmap return arbitrary instance Arbitrary (Chan a) where arbitrary = return $ unsafePerformIO newChan instance Exception (Maybe Bool) data Test a = Test Bool a a deriving (Show, Typeable) instance Functor Test where fmap f (Test a b c) = Test a (f b) (f c) a ==> b = Test False a b a ?==> b = Test True a b class Testable2 a where property2 :: Test a -> Property instance Testable2 a => Testable (Test a) where property = property2 instance Eq a => Testable2 a where property2 (Test bx (catcher -> x) (catcher -> y)) = property $ (bx && isNothing x) || x == y instance (Arbitrary a, Show a, Testable2 b) => Testable2 (a -> b) where property2 x = property $ \a -> fmap ($ a) x {-# NOINLINE bad #-} bad :: IORef Int bad = unsafePerformIO $ newIORef 0 test :: (Show p, Testable p, Typeable p) => FilePath -> Int -> String -> p -> IO () test file line hint p = do res <- quickCheckWithResult stdArgs{chatty=False} p unless (isSuccess res) $ do putStrLn $ "\n" ++ file ++ ":" ++ show line ++ ": " ++ hint print $ typeOf p putStr $ output res modifyIORef bad (+1) catcher :: a -> Maybe a catcher x = unsafePerformIO $ do res <- try $ evaluate x return $ case res of Left (_ :: SomeException) -> Nothing Right v -> Just v _noParen_ = id _eval_ = id withMain :: IO () -> IO () withMain act = do act bad <- readIORef bad when (bad > 0) $ error $ "Failed " ++ show bad ++ " tests" --------------------------------------------------------------------- -- EXAMPLES main :: IO () main = withMain $ do let t = \ a -> (findIndex ((==) a)) ==> (elemIndex a) in test "data\\Default.hs" 144 "findIndex ((==) a) ==> elemIndex a" t let t = ((foldr1 (&&)) ?==> (and)) in test "data\\Default.hs" 179 "foldr1 (&&) ==> and" t let t = \ x -> (sqrt x) ==> (x ** 0.5) in test "data\\Default.hs" 407 "sinh x / cosh x ==> tanh x" t let t = \ (NegZero i) x -> (take i x) ==> ([]) in test "data\\Default.hs" 154 "take i x ==> []" t let t = \ (Compare f) x -> (head (sortBy f x)) ==> (minimumBy f x) in test "data\\Default.hs" 70 "head (sortBy f x) ==> minimumBy f x" t let t = \ f -> ((f $)) ==> (f) in test "data\\Default.hs" 218 "(f $) ==> f" t hlint-1.9.35/data/HLint.hs0000644000000000000000000000012712726504430013403 0ustar0000000000000000 module HLint.HLint where import "hint" HLint.Default import "hint" HLint.Builtin.All hlint-1.9.35/data/hlint.ghci0000644000000000000000000000244412726504430014007 0ustar0000000000000000-- -*- mode: haskell; -*- -- Begin copied material. -- :{ :def redir \varcmd -> return $ case break Data.Char.isSpace varcmd of (var,_:cmd) -> unlines [":set -fno-print-bind-result" ,"tmp <- System.Directory.getTemporaryDirectory" ,"(f,h) <- System.IO.openTempFile tmp \"ghci\"" ,"sto <- GHC.IO.Handle.hDuplicate System.IO.stdout" ,"GHC.IO.Handle.hDuplicateTo h System.IO.stdout" ,"System.IO.hClose h" ,cmd ,"GHC.IO.Handle.hDuplicateTo sto System.IO.stdout" ,"let readFileNow f = readFile f >>= \\t->Data.List.length t `seq` return t" ,var++" <- readFileNow f" ,"System.Directory.removeFile f" ] _ -> "putStrLn \"usage: :redir \"" :} --- Integration with the hlint code style tool :{ :def hlint \extra -> return $ unlines [":unset +t +s" ,":set -w" ,":redir hlintvar1 :show modules" ,":cmd return $ \":! hlint \" ++ unwords (map (takeWhile (/=',') . drop 2 . dropWhile (/= '(')) $ lines hlintvar1) ++ \" \" ++ " ++ show extra ,":set +t +s -Wall" ] :} hlint-1.9.35/data/hlint.10000644000000000000000000000242512726504430013234 0ustar0000000000000000.TH HLINT "1" "July 2009" "HLint (C) Neil Mitchell 2006-2009" "User Commands" .SH NAME HLint \- haskell source code suggestions .SH SYNOPSIS .B hlint [\fIfiles/directories\fR] [\fIoptions\fR] .SH DESCRIPTION \fIHLint\fR is a tool for suggesting possible improvements to Haskell code. These suggestions include ideas such as using alternative functions, simplifying code and spotting redundancies. .SH OPTIONS .TP \fB\-?\fR \fB\-\-help\fR Display help message .TP \fB\-v\fR \fB\-\-version\fR Display version information .TP \fB\-r[file]\fR \fB\-\-report\fR[=\fIfile\fR] Generate a report in HTML .TP \fB\-h\fR \fIfile\fR \fB\-\-hint\fR=\fIfile\fR Hint/ignore file to use .TP \fB\-c\fR \fB\-\-color\fR, \fB\-\-colour\fR Color the output (requires ANSI terminal) .TP \fB\-i\fR \fImessage\fR \fB\-\-ignore\fR=\fImessage\fR Ignore a particular hint .TP \fB\-s\fR \fB\-\-show\fR Show all ignored ideas .TP \fB\-t\fR \fB\-\-test\fR Run in test mode .SH EXAMPLE "To check all Haskell files in 'src' and generate a report type:" .IP hlint src \fB\-\-report\fR .SH "SEE ALSO" The full documentation for .B HLint is available in \fI/usr/share/doc/hlint/hlint.html\fI. .SH AUTHOR This manual page was written by Joachim Breitner for the Debian system (but may be used by others). hlint-1.9.35/data/Generalise.hs0000644000000000000000000000032512726504430014443 0ustar0000000000000000 module HLint.Generalise where import Data.Monoid import Control.Monad hint = concatMap ==> (=<<) hint = liftM ==> fmap where _ = noQuickCheck hint = map ==> fmap hint = a ++ b ==> a `Data.Monoid.mappend` b hlint-1.9.35/data/Dollar.hs0000644000000000000000000000021712726504430013602 0ustar0000000000000000 module HLint.Dollar where warn = a $ b $ c ==> a . b $ c {- yes = concat $ concat $ map f x -- concat . concat $ map f x -} hlint-1.9.35/data/Default.hs0000644000000000000000000007536612726504430013772 0ustar0000000000000000 module HLint.Default where import Control.Arrow import Control.Exception import Control.Monad import Control.Monad.Trans.State import qualified Data.Foldable import Data.Foldable(asum, sequenceA_, traverse_, for_) import Data.Traversable(traverse, for) import Control.Applicative import Data.Function import Data.Int import Data.Char import Data.List as Data.List import Data.List as X import Data.Maybe import Data.Monoid import System.IO import Control.Concurrent.Chan import System.Mem.Weak import Control.Exception.Base import System.Exit import Data.Either import Numeric import IO as System.IO import List as Data.List import Maybe as Data.Maybe import Monad as Control.Monad import Char as Data.Char -- I/O warn = putStrLn (show x) ==> print x warn = mapM_ putChar ==> putStr warn = hGetChar stdin ==> getChar warn = hGetLine stdin ==> getLine warn = hGetContents stdin ==> getContents warn = hPutChar stdout ==> putChar warn = hPutStr stdout ==> putStr warn = hPutStrLn stdout ==> putStrLn warn = hPrint stdout ==> print warn = hWaitForInput a 0 ==> hReady a warn = hPutStrLn a (show b) ==> hPrint a b warn = hIsEOF stdin ==> isEOF -- EXIT warn = exitWith ExitSuccess ==> exitSuccess -- ORD warn = not (a == b) ==> a /= b where note = "incorrect if either value is NaN" warn = not (a /= b) ==> a == b where note = "incorrect if either value is NaN" warn = not (a > b) ==> a <= b where note = "incorrect if either value is NaN" warn = not (a >= b) ==> a < b where note = "incorrect if either value is NaN" warn = not (a < b) ==> a >= b where note = "incorrect if either value is NaN" warn = not (a <= b) ==> a > b where note = "incorrect if either value is NaN" warn = compare x y /= GT ==> x <= y warn = compare x y == LT ==> x < y warn = compare x y /= LT ==> x >= y warn = compare x y == GT ==> x > y warn = compare x y == EQ ==> x == y warn = compare x y /= EQ ==> x /= y --warning = x == a || x == b || x == c ==> x `elem` [a,b,c] where note = ValidInstance "Eq" x --warning = x /= a && x /= b && x /= c ==> x `notElem` [a,b,c] where note = ValidInstance "Eq" x --warn = compare (f x) (f y) ==> Data.Ord.comparing f x y -- not that great --warn = on compare f ==> Data.Ord.comparing f -- not that great warn = head (sort x) ==> minimum x warn = last (sort x) ==> maximum x warn = head (sortBy f x) ==> minimumBy f x where _ = isCompare f warn = last (sortBy f x) ==> maximumBy f x where _ = isCompare f warn "Avoid reverse" = reverse (sort x) ==> sortBy (flip compare) x warn "Avoid reverse" = reverse (sortBy f x) ==> sortBy (flip f) x where _ = isCompare f hint = flip (g `on` h) ==> flip g `on` h hint = (f `on` g) `on` h ==> f `on` (g . h) -- READ/SHOW warn = showsPrec 0 x "" ==> show x warn = readsPrec 0 ==> reads warn = showsPrec 0 ==> shows hint = showIntAtBase 16 intToDigit ==> showHex hint = showIntAtBase 8 intToDigit ==> showOct -- LIST warn = concat (map f x) ==> concatMap f x warn = concat (fmap f x) ==> concatMap f x hint = concat [a, b] ==> a ++ b hint "Use map once" = map f (map g x) ==> map (f . g) x hint "Fuse concatMap/map" = concatMap f (map g x) ==> concatMap (f . g) x hint = x !! 0 ==> head x warn = take n (repeat x) ==> replicate n x where _ = noQuickCheck -- takes too long warn = map f (replicate n x) ==> replicate n (f x) where _ = noQuickCheck -- takes too long warn = map f (repeat x) ==> repeat (f x) where _ = noQuickCheck -- takes forever warn = cycle [x] ==> repeat x where _ = noQuickCheck -- takes forever warn = head (reverse x) ==> last x warn = head (drop n x) ==> x !! n where _ = isNat n warn = reverse (tail (reverse x)) ==> init x where note = IncreasesLaziness warn "Avoid reverse" = reverse (reverse x) ==> x where note = IncreasesLaziness -- warn = take (length x - 1) x ==> init x -- not true for x == [] warn = isPrefixOf (reverse x) (reverse y) ==> isSuffixOf x y warn = foldr (++) [] ==> concat warn = foldr (++) "" ==> concat warn = foldl (++) [] ==> concat where note = IncreasesLaziness warn = foldl (++) "" ==> concat where note = IncreasesLaziness warn = foldl f (head x) (tail x) ==> foldl1 f x warn = foldr f (last x) (init x) ==> foldr1 f x warn = span (not . p) ==> break p warn = break (not . p) ==> span p warn = (takeWhile p x, dropWhile p x) ==> span p x warn = fst (span p x) ==> takeWhile p x warn = snd (span p x) ==> dropWhile p x warn = fst (break p x) ==> takeWhile (not . p) x warn = snd (break p x) ==> dropWhile (not . p) x warn = concatMap (++ "\n") ==> unlines warn = map id ==> id warn = concatMap id ==> concat warn = or (map p x) ==> any p x warn = and (map p x) ==> all p x warn = zipWith (,) ==> zip warn = zipWith3 (,,) ==> zip3 hint = length x == 0 ==> null x where note = IncreasesLaziness hint = x == [] ==> null x hint "Use null" = length x /= 0 ==> not (null x) where note = IncreasesLaziness hint "Use :" = (\x -> [x]) ==> (:[]) warn = map (uncurry f) (zip x y) ==> zipWith f x y hint = map f (zip x y) ==> zipWith (curry f) x y where _ = isVar f warn = not (elem x y) ==> notElem x y hint = foldr f z (map g x) ==> foldr (f . g) z x warn = x ++ concatMap (' ':) y ==> unwords (x:y) warn = intercalate " " ==> unwords hint = concat (intersperse x y) ==> intercalate x y where _ = notEq x " " hint = concat (intersperse " " x) ==> unwords x warn "Use any" = null (filter f x) ==> not (any f x) warn "Use any" = filter f x == [] ==> not (any f x) warn = filter f x /= [] ==> any f x warn = any id ==> or warn = all id ==> and warn = any ((==) a) ==> elem a where note = ValidInstance "Eq" a warn = any (== a) ==> elem a warn = any (a ==) ==> elem a where note = ValidInstance "Eq" a warn = all ((/=) a) ==> notElem a where note = ValidInstance "Eq" a warn = all (/= a) ==> notElem a where note = ValidInstance "Eq" a warn = all (a /=) ==> notElem a where note = ValidInstance "Eq" a warn = elem True ==> or warn = notElem False ==> and warn = findIndex ((==) a) ==> elemIndex a warn = findIndex (a ==) ==> elemIndex a warn = findIndex (== a) ==> elemIndex a warn = findIndices ((==) a) ==> elemIndices a warn = findIndices (a ==) ==> elemIndices a warn = findIndices (== a) ==> elemIndices a warn = lookup b (zip l [0..]) ==> elemIndex b l hint "Length always non-negative" = length x >= 0 ==> True hint "Use null" = length x > 0 ==> not (null x) where note = IncreasesLaziness hint "Use null" = length x >= 1 ==> not (null x) where note = IncreasesLaziness warn "Take on a non-positive" = take i x ==> [] where _ = isNegZero i warn "Drop on a non-positive" = drop i x ==> x where _ = isNegZero i warn = last (scanl f z x) ==> foldl f z x warn = head (scanr f z x) ==> foldr f z x warn = iterate id ==> repeat where _ = noQuickCheck -- takes forever warn = zipWith f (repeat x) ==> map (f x) warn = zipWith f y (repeat z) ==> map (\x -> f x z) y -- BY warn = deleteBy (==) ==> delete warn = groupBy (==) ==> group warn = insertBy compare ==> insert warn = intersectBy (==) ==> intersect warn = maximumBy compare ==> maximum warn = minimumBy compare ==> minimum warn = nubBy (==) ==> nub warn = sortBy compare ==> sort warn = unionBy (==) ==> union -- FOLDS warn = foldr (>>) (return ()) ==> sequence_ where _ = noQuickCheck warn = foldr (&&) True ==> and warn = foldl (&&) True ==> and where note = IncreasesLaziness warn = foldr1 (&&) ==> and where note = RemovesError "on []"; _ = noQuickCheck warn = foldl1 (&&) ==> and where note = RemovesError "on []" warn = foldr (||) False ==> or warn = foldl (||) False ==> or where note = IncreasesLaziness warn = foldr1 (||) ==> or where note = RemovesError "on []" warn = foldl1 (||) ==> or where note = RemovesError "on []" warn = foldl (+) 0 ==> sum warn = foldr (+) 0 ==> sum warn = foldl1 (+) ==> sum where note = RemovesError "on []" warn = foldr1 (+) ==> sum where note = RemovesError "on []" warn = foldl (*) 1 ==> product warn = foldr (*) 1 ==> product warn = foldl1 (*) ==> product where note = RemovesError "on []" warn = foldr1 (*) ==> product where note = RemovesError "on []" warn = foldl1 max ==> maximum warn = foldr1 max ==> maximum warn = foldl1 min ==> minimum warn = foldr1 min ==> minimum warn = foldr mplus mzero ==> msum where _ = noQuickCheck -- FUNCTION warn = (\x -> x) ==> id warn = (\x y -> x) ==> const warn = (\(x,y) -> y) ==> snd warn = (\(x,y) -> x) ==> fst hint "Use curry" = (\x y -> f (x,y)) ==> curry f hint "Use uncurry" = (\(x,y) -> f x y) ==> uncurry f where note = IncreasesLaziness warn "Redundant $" = (($) . f) ==> f warn "Redundant $" = (f $) ==> f hint = (\x -> y) ==> const y where _ = isAtom y && not (isWildcard y) warn "Redundant flip" = flip f x y ==> f y x where _ = isApp original warn "Evaluate" = id x ==> x warn "Redundant id" = id . x ==> x warn "Redundant id" = x . id ==> x -- CHAR warn = a >= 'a' && a <= 'z' ==> isAsciiLower a warn = a >= 'A' && a <= 'Z' ==> isAsciiUpper a warn = a >= '0' && a <= '9' ==> isDigit a warn = a >= '0' && a <= '7' ==> isOctDigit a warn = isLower a || isUpper a ==> isAlpha a warn = isUpper a || isLower a ==> isAlpha a -- BOOL warn "Redundant ==" = x == True ==> x hint "Redundant ==" = x == False ==> not x warn "Redundant ==" = True == a ==> a hint "Redundant ==" = False == a ==> not a warn "Redundant /=" = a /= True ==> not a hint "Redundant /=" = a /= False ==> a warn "Redundant /=" = True /= a ==> not a hint "Redundant /=" = False /= a ==> a warn "Redundant if" = (if a then x else x) ==> x where note = IncreasesLaziness warn "Redundant if" = (if a then True else False) ==> a warn "Redundant if" = (if a then False else True) ==> not a warn "Redundant if" = (if a then t else (if b then t else f)) ==> if a || b then t else f warn "Redundant if" = (if a then (if b then t else f) else f) ==> if a && b then t else f warn "Redundant if" = (if x then True else y) ==> x || y where _ = notEq y False warn "Redundant if" = (if x then y else False) ==> x && y where _ = notEq y True hint "Use if" = case a of {True -> t; False -> f} ==> if a then t else f hint "Use if" = case a of {False -> f; True -> t} ==> if a then t else f hint "Use if" = case a of {True -> t; _ -> f} ==> if a then t else f hint "Use if" = case a of {False -> f; _ -> t} ==> if a then t else f hint "Redundant if" = (if c then (True, x) else (False, x)) ==> (c, x) where note = IncreasesLaziness hint "Redundant if" = (if c then (False, x) else (True, x)) ==> (not c, x) where note = IncreasesLaziness hint = or [x, y] ==> x || y hint = or [x, y, z] ==> x || y || z hint = and [x, y] ==> x && y hint = and [x, y, z] ==> x && y && z warn "Redundant if" = (if x then False else y) ==> not x && y where _ = notEq y True warn "Redundant if" = (if x then y else True) ==> not x || y where _ = notEq y False warn "Redundant not" = not (not x) ==> x -- warn "Too strict if" = (if c then f x else f y) ==> f (if c then x else y) where note = IncreasesLaziness -- also breaks types, see #87 -- ARROW warn = id *** g ==> second g warn = f *** id ==> first f warn = zip (map f x) (map g x) ==> map (f Control.Arrow.&&& g) x hint = (\(x,y) -> (f x, g y)) ==> f Control.Arrow.*** g hint = (\x -> (f x, g x)) ==> f Control.Arrow.&&& g hint = (\(x,y) -> (f x,y)) ==> Control.Arrow.first f hint = (\(x,y) -> (x,f y)) ==> Control.Arrow.second f hint = (f (fst x), g (snd x)) ==> (f Control.Arrow.*** g) x hint "Redundant pair" = (fst x, snd x) ==> x where note = DecreasesLaziness -- FUNCTOR warn "Functor law" = fmap f (fmap g x) ==> fmap (f . g) x where _ = noQuickCheck warn "Functor law" = f <$> g <$> x ==> f . g <$> x where _ = noQuickCheck warn "Functor law" = fmap id ==> id where _ = noQuickCheck warn "Functor law" = id <$> x ==> x where _ = noQuickCheck hint = fmap f $ x ==> f Control.Applicative.<$> x where _ = (isApp x || isAtom x) && noQuickCheck -- MONAD warn "Monad law, left identity" = return a >>= f ==> f a where _ = noQuickCheck warn "Monad law, left identity" = f =<< return a ==> f a where _ = noQuickCheck warn "Monad law, right identity" = m >>= return ==> m where _ = noQuickCheck warn "Monad law, right identity" = return =<< m ==> m where _ = noQuickCheck warn = liftM ==> fmap hint = m >>= return . f ==> fmap f m where _ = noQuickCheck -- cannot be fmap, because is in Functor not Monad hint = return . f =<< m ==> fmap f m where _ = noQuickCheck warn = (if x then y else return ()) ==> Control.Monad.when x $ _noParen_ y where _ = not (isAtom y) && noQuickCheck warn = (if x then y else return ()) ==> Control.Monad.when x y where _ = isAtom y && noQuickCheck warn = (if x then return () else y) ==> Control.Monad.unless x $ _noParen_ y where _ = not (isAtom y) && noQuickCheck warn = (if x then return () else y) ==> Control.Monad.unless x y where _ = isAtom y && noQuickCheck warn = sequence (map f x) ==> mapM f x where _ = noQuickCheck warn = sequence_ (map f x) ==> mapM_ f x where _ = noQuickCheck hint = flip mapM ==> Control.Monad.forM where _ = noQuickCheck hint = flip mapM_ ==> Control.Monad.forM_ where _ = noQuickCheck hint = flip forM ==> mapM where _ = noQuickCheck hint = flip forM_ ==> mapM_ where _ = noQuickCheck warn = when (not x) ==> unless x where _ = noQuickCheck warn = x >>= id ==> Control.Monad.join x where _ = noQuickCheck warn = id =<< x ==> Control.Monad.join x where _ = noQuickCheck hint = a >> return () ==> Control.Monad.void a where _ = (isAtom a || isApp a) && noQuickCheck warn = fmap (const ()) ==> Control.Monad.void where _ = noQuickCheck warn = const () <$> x ==> Control.Monad.void x where _ = noQuickCheck warn = flip (>=>) ==> (<=<) where _ = noQuickCheck warn = flip (<=<) ==> (>=>) where _ = noQuickCheck warn = flip (>>=) ==> (=<<) where _ = noQuickCheck warn = flip (=<<) ==> (>>=) where _ = noQuickCheck hint = (\x -> f x >>= g) ==> f Control.Monad.>=> g where _ = noQuickCheck hint = (\x -> f =<< g x) ==> f Control.Monad.<=< g where _ = noQuickCheck warn = a >> forever a ==> forever a where _ = noQuickCheck hint = liftM2 id ==> ap where _ = noQuickCheck warn = mapM (uncurry f) (zip l m) ==> zipWithM f l m where _ = noQuickCheck warn = mapM_ (void . f) ==> mapM_ f warn = mapM_ (void f) ==> mapM_ f warn = forM_ x (void . f) ==> forM_ x f warn = forM_ x (void f) ==> forM_ x f warn = void (mapM f x) ==> mapM_ f x warn = void (forM x f) ==> forM_ x f -- STATE MONAD warn = fst (runState x y) ==> evalState x y where _ = noQuickCheck warn = snd (runState x y) ==> execState x y where _ = noQuickCheck -- MONAD LIST warn = fmap unzip (mapM f x) ==> Control.Monad.mapAndUnzipM f x where _ = noQuickCheck warn = sequence (zipWith f x y) ==> Control.Monad.zipWithM f x y where _ = noQuickCheck warn = sequence_ (zipWith f x y) ==> Control.Monad.zipWithM_ f x y where _ = noQuickCheck warn = sequence (replicate n x) ==> Control.Monad.replicateM n x where _ = noQuickCheck warn = sequence_ (replicate n x) ==> Control.Monad.replicateM_ n x where _ = noQuickCheck warn = mapM f (replicate n x) ==> Control.Monad.replicateM n (f x) where _ = noQuickCheck warn = mapM_ f (replicate n x) ==> Control.Monad.replicateM_ n (f x) where _ = noQuickCheck warn = mapM f (map g x) ==> mapM (f . g) x where _ = noQuickCheck warn = mapM_ f (map g x) ==> mapM_ (f . g) x where _ = noQuickCheck warn = mapM id ==> sequence where _ = noQuickCheck warn = mapM_ id ==> sequence_ where _ = noQuickCheck -- APPLICATIVE / TRAVERSABLE warn = flip traverse ==> for where _ = noQuickCheck warn = flip for ==> traverse where _ = noQuickCheck warn = flip traverse_ ==> for_ where _ = noQuickCheck warn = flip for_ ==> traverse_ where _ = noQuickCheck warn = foldr (*>) (pure ()) ==> sequenceA_ where _ = noQuickCheck warn = foldr (<|>) empty ==> asum where _ = noQuickCheck warn = liftA2 (flip ($)) ==> (<**>) where _ = noQuickCheck warn = Just <$> a <|> pure Nothing ==> optional a where _ = noQuickCheck -- LIST COMP hint "Use list comprehension" = (if b then [x] else []) ==> [x | b] hint "Redundant list comprehension" = [x | x <- y] ==> y where _ = isVar x -- SEQ warn "Redundant seq" = x `seq` x ==> x warn "Redundant seq" = join seq ==> id warn "Redundant $!" = id $! x ==> x warn "Redundant seq" = x `seq` y ==> y where _ = isWHNF x warn "Redundant $!" = f $! x ==> f x where _ = isWHNF x warn "Redundant evaluate" = evaluate x ==> return x where _ = isWHNF x -- MAYBE warn = maybe x id ==> Data.Maybe.fromMaybe x warn = maybe False (const True) ==> Data.Maybe.isJust warn = maybe True (const False) ==> Data.Maybe.isNothing warn = not (isNothing x) ==> isJust x warn = not (isJust x) ==> isNothing x warn = maybe [] (:[]) ==> maybeToList warn = catMaybes (map f x) ==> mapMaybe f x hint = (case x of Nothing -> y; Just a -> a) ==> fromMaybe y x warn = (if isNothing x then y else f (fromJust x)) ==> maybe y f x warn = (if isJust x then f (fromJust x) else y) ==> maybe y f x warn = maybe Nothing (Just . f) ==> fmap f hint = map fromJust . filter isJust ==> Data.Maybe.catMaybes warn = x == Nothing ==> isNothing x warn = Nothing == x ==> isNothing x warn = x /= Nothing ==> Data.Maybe.isJust x warn = Nothing /= x ==> Data.Maybe.isJust x warn = concatMap (maybeToList . f) ==> Data.Maybe.mapMaybe f warn = concatMap maybeToList ==> catMaybes warn = maybe n Just x ==> x Control.Applicative.<|> n hint = (case x of Just a -> a; Nothing -> y) ==> fromMaybe y x warn = (if isNothing x then y else fromJust x) ==> fromMaybe y x warn = (if isJust x then fromJust x else y) ==> fromMaybe y x warn = isJust x && (fromJust x == y) ==> x == Just y warn = mapMaybe f (map g x) ==> mapMaybe (f . g) x warn = fromMaybe a (fmap f x) ==> maybe a f x warn = mapMaybe id ==> catMaybes hint = [x | Just x <- a] ==> Data.Maybe.catMaybes a hint = (case m of Nothing -> Nothing; Just x -> x) ==> Control.Monad.join m hint = maybe Nothing id ==> join hint "Too strict maybe" = maybe (f x) (f . g) ==> f . maybe x g where note = IncreasesLaziness -- EITHER warn = [a | Left a <- a] ==> lefts a warn = [a | Right a <- a] ==> rights a warn = either Left (Right . f) ==> fmap f -- INFIX hint "Use infix" = elem x y ==> x `elem` y where _ = not (isInfixApp original) && not (isParen result) hint "Use infix" = notElem x y ==> x `notElem` y where _ = not (isInfixApp original) && not (isParen result) hint "Use infix" = isInfixOf x y ==> x `isInfixOf` y where _ = not (isInfixApp original) && not (isParen result) hint "Use infix" = isSuffixOf x y ==> x `isSuffixOf` y where _ = not (isInfixApp original) && not (isParen result) hint "Use infix" = isPrefixOf x y ==> x `isPrefixOf` y where _ = not (isInfixApp original) && not (isParen result) hint "Use infix" = union x y ==> x `union` y where _ = not (isInfixApp original) && not (isParen result) hint "Use infix" = intersect x y ==> x `intersect` y where _ = not (isInfixApp original) && not (isParen result) -- MATHS warn "Redundant fromIntegral" = fromIntegral x ==> x where _ = isLitInt x warn "Redundant fromInteger" = fromInteger x ==> x where _ = isLitInt x hint = x + negate y ==> x - y hint = 0 - x ==> negate x warn "Redundant negate" = negate (negate x) ==> x hint = log y / log x ==> logBase x y hint = sin x / cos x ==> tan x hint = n `rem` 2 == 0 ==> even n hint = n `rem` 2 /= 0 ==> odd n hint = not (even x) ==> odd x hint = not (odd x) ==> even x hint = x ** 0.5 ==> sqrt x hint "Use 1" = x ^ 0 ==> 1 hint = round (x - 0.5) ==> floor x -- CONCURRENT hint = mapM_ (writeChan a) ==> writeList2Chan a -- EXCEPTION hint = flip Control.Exception.catch ==> handle hint = flip handle ==> Control.Exception.catch hint = flip (catchJust p) ==> handleJust p hint = flip (handleJust p) ==> catchJust p hint = Control.Exception.bracket b (const a) (const t) ==> Control.Exception.bracket_ b a t hint = Control.Exception.bracket (openFile x y) hClose ==> withFile x y hint = Control.Exception.bracket (openBinaryFile x y) hClose ==> withBinaryFile x y hint = throw (ErrorCall a) ==> error a warn = toException NonTermination ==> nonTermination warn = toException NestedAtomically ==> nestedAtomically -- WEAK POINTERS warn = mkWeak a a b ==> mkWeakPtr a b warn = mkWeak a (a, b) c ==> mkWeakPair a b c -- FOLDABLE warn "Use Foldable.forM_" = (case m of Nothing -> return (); Just x -> f x) ==> Data.Foldable.forM_ m f where _ = noQuickCheck warn "Use Foldable.forM_" = when (isJust m) (f (fromJust m)) ==> Data.Foldable.forM_ m f where _ = noQuickCheck -- EVALUATE -- TODO: These should be moved in to HSE\Evaluate.hs and applied -- through a special evaluate hint mechanism warn "Evaluate" = True && x ==> x warn "Evaluate" = False && x ==> False warn "Evaluate" = True || x ==> True warn "Evaluate" = False || x ==> x warn "Evaluate" = not True ==> False warn "Evaluate" = not False ==> True warn "Evaluate" = Nothing >>= k ==> Nothing warn "Evaluate" = k =<< Nothing ==> Nothing warn "Evaluate" = either f g (Left x) ==> f x warn "Evaluate" = either f g (Right y) ==> g y warn "Evaluate" = fst (x,y) ==> x warn "Evaluate" = snd (x,y) ==> y warn "Evaluate" = f (fst p) (snd p) ==> uncurry f p warn "Evaluate" = init [x] ==> [] warn "Evaluate" = null [] ==> True warn "Evaluate" = length [] ==> 0 warn "Evaluate" = foldl f z [] ==> z warn "Evaluate" = foldr f z [] ==> z warn "Evaluate" = foldr1 f [x] ==> x warn "Evaluate" = scanr f z [] ==> [z] warn "Evaluate" = scanr1 f [] ==> [] warn "Evaluate" = scanr1 f [x] ==> [x] warn "Evaluate" = take n [] ==> [] where note = IncreasesLaziness warn "Evaluate" = drop n [] ==> [] where note = IncreasesLaziness warn "Evaluate" = takeWhile p [] ==> [] warn "Evaluate" = dropWhile p [] ==> [] warn "Evaluate" = span p [] ==> ([],[]) warn "Evaluate" = lines "" ==> [] warn "Evaluate" = unwords [] ==> "" warn "Evaluate" = x - 0 ==> x warn "Evaluate" = x * 1 ==> x warn "Evaluate" = x / 1 ==> x warn "Evaluate" = concat [a] ==> a warn "Evaluate" = concat [] ==> [] warn "Evaluate" = zip [] [] ==> [] warn "Evaluate" = const x y ==> x -- FOLDABLE + TUPLES warn "Using foldr on tuple" = foldr f z (x,b) ==> f b z warn "Using foldr' on tuple" = foldr' f z (x,b) ==> f b z warn "Using foldl on tuple" = foldl f z (x,b) ==> f z b warn "Using foldl' on tuple" = foldl' f z (x,b) ==> f z b warn "Using foldMap on tuple" = foldMap f (x,b) ==> f b warn "Using foldr1 on tuple" = foldr1 f (x,b) ==> b warn "Using foldl1 on tuple" = foldl1 f (x,b) ==> b warn "Using elem on tuple" = elem e (x,b) ==> e == b warn "Using fold on tuple" = fold (x,b) ==> b warn "Using toList on tuple" = toList (x,b) ==> b warn "Using maximum on tuple" = maximum (x,b) ==> b warn "Using minimum on tuple" = minimum (x,b) ==> b warn "Using sum on tuple" = sum (x,b) ==> b warn "Using product on tuple" = product (x,b) ==> b warn "Using concat on tuple" = concat (x,b) ==> b warn "Using and on tuple" = and (x,b) ==> b warn "Using or on tuple" = or (x,b) ==> b warn "Using any on tuple" = any f (x,b) ==> f b warn "Using all on tuple" = all f (x,b) ==> f b warn "Using foldr on tuple" = foldr f z (x,y,b) ==> f b z warn "Using foldr' on tuple" = foldr' f z (x,y,b) ==> f b z warn "Using foldl on tuple" = foldl f z (x,y,b) ==> f z b warn "Using foldl' on tuple" = foldl' f z (x,y,b) ==> f z b warn "Using foldMap on tuple" = foldMap f (x,y,b) ==> f b warn "Using foldr1 on tuple" = foldr1 f (x,y,b) ==> b warn "Using foldl1 on tuple" = foldl1 f (x,y,b) ==> b warn "Using elem on tuple" = elem e (x,y,b) ==> e == b warn "Using fold on tuple" = fold (x,y,b) ==> b warn "Using toList on tuple" = toList (x,y,b) ==> b warn "Using maximum on tuple" = maximum (x,y,b) ==> b warn "Using minimum on tuple" = minimum (x,y,b) ==> b warn "Using sum on tuple" = sum (x,y,b) ==> b warn "Using product on tuple" = product (x,y,b) ==> b warn "Using concat on tuple" = concat (x,y,b) ==> b warn "Using and on tuple" = and (x,y,b) ==> b warn "Using or on tuple" = or (x,y,b) ==> b warn "Using any on tuple" = any f (x,y,b) ==> f b warn "Using all on tuple" = all f (x,y,b) ==> f b warn "Using null on tuple" = null x ==> False where _ = isTuple x warn "Using length on tuple" = length x ==> 1 where _ = isTuple x -- COMPLEX {- -- these would be a good idea, but we have not yet proven them and they seem to have side conditions warn "Use isPrefixOf" = take (length t) s == t ==> t `Data.List.isPrefixOf` s warn "Use isPrefixOf" = (take i s == t) ==> _eval_ ((i >= length t) && (t `Data.List.isPrefixOf` s)) where _ = (isList t || isLit t) && isPos i -} {- -- clever hint, but not actually a good idea hint = (do a <- f; g a) ==> f >>= g where _ = (isAtom f || isApp f) -} test = hints named test are to allow people to put test code within hint files testPrefix = and any prefix also works {- yes = concat . map f -- concatMap f yes = foo . bar . concat . map f . baz . bar -- concatMap f . baz . bar yes = map f (map g x) -- map (f . g) x yes = concat.map (\x->if x==e then l' else [x]) -- concatMap (\x->if x==e then l' else [x]) yes = f x where f x = concat . map head -- concatMap head yes = concat . map f . g -- concatMap f . g yes = concat $ map f x -- concatMap f x yes = "test" ++ concatMap (' ':) ["of","this"] -- unwords ("test":["of","this"]) yes = if f a then True else b -- f a || b yes = not (a == b) -- a /= b yes = not (a /= b) -- a == b yes = not . (a ==) -- (a /=) yes = not . (== a) -- (/= a) yes = not . (a /=) -- (a ==) yes = not . (/= a) -- (== a) yes = if a then 1 else if b then 1 else 2 -- if a || b then 1 else 2 no = if a then 1 else if b then 3 else 2 yes = a >>= return . bob -- fmap bob a yes = (x !! 0) + (x !! 2) -- head x yes = if b < 42 then [a] else [] -- [a | b < 42] no = take n (foo xs) == "hello" yes = head (reverse xs) -- last xs yes = reverse xs `isPrefixOf` reverse ys -- isSuffixOf xs ys no = putStrLn $ show (length xs) ++ "Test" yes = ftable ++ map (\ (c, x) -> (toUpper c, urlEncode x)) ftable -- toUpper Control.Arrow.*** urlEncode yes = map (\(a,b) -> a) xs -- fst yes = map (\(a,_) -> a) xs -- fst yes = readFile $ args !! 0 -- head args yes = if Debug `elem` opts then ["--debug"] else [] -- ["--debug" | Debug `elem` opts] yes = if nullPS s then return False else if headPS s /= '\n' then return False else alter_input tailPS >> return True \ -- if nullPS s || (headPS s /= '\n') then return False else alter_input tailPS >> return True yes = if foo then do stuff; moreStuff; lastOfTheStuff else return () \ -- Control.Monad.when foo $ do stuff ; moreStuff ; lastOfTheStuff yes = if foo then stuff else return () -- Control.Monad.when foo stuff yes = foo $ \(a, b) -> (a, y + b) -- Control.Arrow.second ((+) y) no = foo $ \(a, b) -> (a, a + b) yes = map (uncurry (+)) $ zip [1 .. 5] [6 .. 10] -- zipWith (+) [1 .. 5] [6 .. 10] no = do iter <- textBufferGetTextIter tb ; textBufferSelectRange tb iter iter no = flip f x $ \y -> y*y+y no = \x -> f x (g x) no = foo (\ v -> f v . g) yes = concat . intersperse " " -- unwords yes = Prelude.concat $ intersperse " " xs -- unwords xs yes = concat $ Data.List.intersperse " " xs -- unwords xs yes = if a then True else False -- a yes = if x then true else False -- x && true yes = elem x y -- x `elem` y yes = foo (elem x y) -- x `elem` y no = x `elem` y no = elem 1 [] : [] test a = foo (\x -> True) -- const True h a = flip f x (y z) -- f (y z) x h a = flip f x $ y z yes x = case x of {True -> a ; False -> b} -- if x then a else b yes x = case x of {False -> a ; _ -> b} -- if x then b else a no = const . ok . toResponse $ "saved" yes = case x z of Nothing -> y z; Just pat -> pat -- fromMaybe (y z) (x z) yes = if p then s else return () -- Control.Monad.when p s warn = a $$$$ b $$$$ c ==> a . b $$$$$ c yes = when (not . null $ asdf) -- unless (null asdf) yes = id 1 -- 1 yes = case concat (map f x) of [] -> [] -- concatMap f x yes = [v | v <- xs] -- xs no = [Left x | Left x <- xs] when p s = if p then s else return () no = x ^^ 18.5 instance Arrow (->) where first f = f *** id yes = fromInteger 12 -- 12 import Prelude hiding (catch); no = catch import Control.Exception as E; no = E.catch main = do f; putStrLn $ show x -- print x main = map (writer,) $ map arcObj $ filter (rdfPredEq (Res dctreferences)) ts -- map ((writer,) . arcObj) (filter (rdfPredEq (Res dctreferences)) ts) h x y = return $! (x, y) -- return (x, y) h x y = return $! x getInt = do { x <- readIO "0"; return $! (x :: Int) } foo = evaluate [12] -- return [12] test = \ a -> f a >>= \ b -> return (a, b) fooer input = catMaybes . map Just $ input -- mapMaybe Just yes = mapMaybe id -- catMaybes main = print $ map (\_->5) [2,3,5] -- const 5 main = head $ drop n x main = head $ drop (-3) x -- x main = head $ drop 2 x -- x !! 2 main = drop 0 x -- x main = take 0 x -- [] main = take (-5) x -- [] main = take (-y) x main = take 4 x main = let (first, rest) = (takeWhile p l, dropWhile p l) in rest -- span p l main = map $ \ d -> ([| $d |], [| $d |]) pairs (x:xs) = map (\y -> (x,y)) xs ++ pairs xs {-# ANN foo "HLint: ignore" #-};foo = map f (map g x) -- @Ignore ??? yes = fmap lines $ abc 123 -- lines Control.Applicative.<$> abc 123 no = fmap lines $ abc $ def 123 test = foo . not . not -- id test = map (not . not) xs -- id used = not . not . any (`notElem` special) . fst . derives -- any (`notElem` special) . fst . derives test = foo . id . map -- map test = food id xs yes = baz baz >> return () -- Control.Monad.void (baz baz) no = foo >>= bar >>= something >>= elsee >> return () no = f (#) x data Pair = P {a :: !Int}; foo = return $! P{a=undefined} data Pair = P {a :: !Int}; foo = return $! P undefined foo = return $! Just undefined -- return (Just undefined) foo = return $! (a,b) -- return (a,b) foo = return $! 1 foo = return $! "test" bar = [x | (x,_) <- pts] return' x = x `seq` return x foo = last (sortBy (compare `on` fst) xs) -- maximumBy (compare `on` fst) xs g = \ f -> parseFile f >>= (\ cu -> return (f, cu)) foo = bar $ \(x,y) -> x x y foo = (\x -> f x >>= g) -- f Control.Monad.>=> g foo = (\f -> h f >>= g) -- h Control.Monad.>=> g foo = (\f -> h f >>= f) foo = bar $ \x -> [x,y] foo = bar $ \x -> [z,y] -- const [z,y] f condition tChar tBool = if condition then _monoField tChar else _monoField tBool foo = maybe Bar{..} id -- Data.Maybe.fromMaybe Bar{..} foo = (\a -> Foo {..}) 1 foo = zipWith SymInfo [0 ..] (repeat ty) -- map (\ x -> SymInfo x ty) [0 ..] f rec = rec mean x = fst $ foldl (\(m, n) x' -> (m+(x'-m)/(n+1),n+1)) (0,0) x import Prelude \ yes = flip mapM -- Control.Monad.forM import Control.Monad \ yes = flip mapM -- forM import Control.Monad(forM) \ yes = flip mapM -- forM import Control.Monad(forM_) \ yes = flip mapM -- Control.Monad.forM import qualified Control.Monad \ yes = flip mapM -- Control.Monad.forM import qualified Control.Monad as CM \ yes = flip mapM -- CM.forM import qualified Control.Monad as CM(forM,filterM) \ yes = flip mapM -- CM.forM import Control.Monad as CM(forM,filterM) \ yes = flip mapM -- forM import Control.Monad hiding (forM) \ yes = flip mapM -- Control.Monad.forM import Control.Monad hiding (filterM) \ yes = flip mapM -- forM import qualified Data.Text.Lazy as DTL \ main = DTL.concat $ map (`DTL.snoc` '-') [DTL.pack "one", DTL.pack "two", DTL.pack "three"] import Text.Blaze.Html5.Attributes as A \ main = A.id (stringValue id') import Prelude((==)) \ import qualified Prelude as P \ main = P.length xs == 0 -- P.null xs -}