stan (empty) → 0.0.0.0
raw patch · 67 files changed
+8593/−0 lines, 67 filesdep +arraydep +basedep +base64
Dependencies added: array, base, base64, blaze-html, bytestring, clay, colourista, containers, cryptohash-sha1, dir-traverse, directory, extensions, filepath, ghc, ghc-boot-th, gitrev, hedgehog, hspec, hspec-hedgehog, optparse-applicative, pretty-simple, relude, slist, stan, text, tomland, trial, trial-optparse-applicative, trial-tomland, unordered-containers
Files
- CHANGELOG.md +11/−0
- LICENSE +373/−0
- README.md +497/−0
- app/Main.hs +7/−0
- src/Stan.hs +149/−0
- src/Stan/Analysis.hs +182/−0
- src/Stan/Analysis/Analyser.hs +409/−0
- src/Stan/Analysis/Pretty.hs +174/−0
- src/Stan/Analysis/Summary.hs +97/−0
- src/Stan/Cabal.hs +132/−0
- src/Stan/Category.hs +79/−0
- src/Stan/Cli.hs +343/−0
- src/Stan/Config.hs +467/−0
- src/Stan/Config/Pretty.hs +92/−0
- src/Stan/Core/Id.hs +46/−0
- src/Stan/Core/List.hs +46/−0
- src/Stan/Core/ModuleName.hs +31/−0
- src/Stan/EnvVars.hs +41/−0
- src/Stan/Example.hs +63/−0
- src/Stan/FileInfo.hs +57/−0
- src/Stan/Ghc/Compat.hs +59/−0
- src/Stan/Hie.hs +99/−0
- src/Stan/Hie/Compat.hs +40/−0
- src/Stan/Hie/Debug.hs +80/−0
- src/Stan/Hie/MatchAst.hs +92/−0
- src/Stan/Hie/MatchType.hs +83/−0
- src/Stan/Info.hs +105/−0
- src/Stan/Inspection.hs +163/−0
- src/Stan/Inspection/All.hs +55/−0
- src/Stan/Inspection/AntiPattern.hs +390/−0
- src/Stan/Inspection/Infinite.hs +96/−0
- src/Stan/Inspection/Partial.hs +289/−0
- src/Stan/Inspection/Style.hs +67/−0
- src/Stan/NameMeta.hs +182/−0
- src/Stan/Observation.hs +262/−0
- src/Stan/Pattern/Ast.hs +295/−0
- src/Stan/Pattern/Edsl.hs +40/−0
- src/Stan/Pattern/Type.hs +182/−0
- src/Stan/Report.hs +29/−0
- src/Stan/Report/Css.hs +320/−0
- src/Stan/Report/Html.hs +453/−0
- src/Stan/Report/Settings.hs +47/−0
- src/Stan/Severity.hs +72/−0
- src/Stan/Toml.hs +195/−0
- stan.cabal +207/−0
- target/Target/AntiPattern.hs +94/−0
- target/Target/AntiPattern/Stan0206.hs +22/−0
- target/Target/AntiPattern/Stan0206Extensions.hs +13/−0
- target/Target/AntiPattern/Stan0212.hs +25/−0
- target/Target/AntiPattern/Stan0213.hs +65/−0
- target/Target/AntiPattern/Stan0214.hs +44/−0
- target/Target/Infinite.hs +29/−0
- target/Target/Partial.hs +90/−0
- target/Target/Style.hs +21/−0
- test/Spec.hs +36/−0
- test/Test/Stan/Analysis.hs +68/−0
- test/Test/Stan/Analysis/AntiPattern.hs +196/−0
- test/Test/Stan/Analysis/Common.hs +137/−0
- test/Test/Stan/Analysis/Infinite.hs +35/−0
- test/Test/Stan/Analysis/Partial.hs +52/−0
- test/Test/Stan/Analysis/Style.hs +34/−0
- test/Test/Stan/Cli.hs +70/−0
- test/Test/Stan/Config.hs +145/−0
- test/Test/Stan/Gen.hs +120/−0
- test/Test/Stan/Number.hs +20/−0
- test/Test/Stan/Observation.hs +25/−0
- test/Test/Stan/Toml.hs +54/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog++`stan` uses [PVP Versioning][1].+The change log is available [on GitHub][2].++## 0.0.0.0++* Initially created.++[1]: https://pvp.haskell.org+[2]: https://github.com/kowainik/stan/releases
+ LICENSE view
@@ -0,0 +1,373 @@+Mozilla Public License Version 2.0+==================================++1. Definitions+--------------++1.1. "Contributor"+ means each individual or legal entity that creates, contributes to+ the creation of, or owns Covered Software.++1.2. "Contributor Version"+ means the combination of the Contributions of others (if any) used+ by a Contributor and that particular Contributor's Contribution.++1.3. "Contribution"+ means Covered Software of a particular Contributor.++1.4. "Covered Software"+ means Source Code Form to which the initial Contributor has attached+ the notice in Exhibit A, the Executable Form of such Source Code+ Form, and Modifications of such Source Code Form, in each case+ including portions thereof.++1.5. "Incompatible With Secondary Licenses"+ means++ (a) that the initial Contributor has attached the notice described+ in Exhibit B to the Covered Software; or++ (b) that the Covered Software was made available under the terms of+ version 1.1 or earlier of the License, but not also under the+ terms of a Secondary License.++1.6. "Executable Form"+ means any form of the work other than Source Code Form.++1.7. "Larger Work"+ means a work that combines Covered Software with other material, in+ a separate file or files, that is not Covered Software.++1.8. "License"+ means this document.++1.9. "Licensable"+ means having the right to grant, to the maximum extent possible,+ whether at the time of the initial grant or subsequently, any and+ all of the rights conveyed by this License.++1.10. "Modifications"+ means any of the following:++ (a) any file in Source Code Form that results from an addition to,+ deletion from, or modification of the contents of Covered+ Software; or++ (b) any new file in Source Code Form that contains any Covered+ Software.++1.11. "Patent Claims" of a Contributor+ means any patent claim(s), including without limitation, method,+ process, and apparatus claims, in any patent Licensable by such+ Contributor that would be infringed, but for the grant of the+ License, by the making, using, selling, offering for sale, having+ made, import, or transfer of either its Contributions or its+ Contributor Version.++1.12. "Secondary License"+ means either the GNU General Public License, Version 2.0, the GNU+ Lesser General Public License, Version 2.1, the GNU Affero General+ Public License, Version 3.0, or any later versions of those+ licenses.++1.13. "Source Code Form"+ means the form of the work preferred for making modifications.++1.14. "You" (or "Your")+ means an individual or a legal entity exercising rights under this+ License. For legal entities, "You" includes any entity that+ controls, is controlled by, or is under common control with You. For+ purposes of this definition, "control" means (a) the power, direct+ or indirect, to cause the direction or management of such entity,+ whether by contract or otherwise, or (b) ownership of more than+ fifty percent (50%) of the outstanding shares or beneficial+ ownership of such entity.++2. License Grants and Conditions+--------------------------------++2.1. Grants++Each Contributor hereby grants You a world-wide, royalty-free,+non-exclusive license:++(a) under intellectual property rights (other than patent or trademark)+ Licensable by such Contributor to use, reproduce, make available,+ modify, display, perform, distribute, and otherwise exploit its+ Contributions, either on an unmodified basis, with Modifications, or+ as part of a Larger Work; and++(b) under Patent Claims of such Contributor to make, use, sell, offer+ for sale, have made, import, and otherwise transfer either its+ Contributions or its Contributor Version.++2.2. Effective Date++The licenses granted in Section 2.1 with respect to any Contribution+become effective for each Contribution on the date the Contributor first+distributes such Contribution.++2.3. Limitations on Grant Scope++The licenses granted in this Section 2 are the only rights granted under+this License. No additional rights or licenses will be implied from the+distribution or licensing of Covered Software under this License.+Notwithstanding Section 2.1(b) above, no patent license is granted by a+Contributor:++(a) for any code that a Contributor has removed from Covered Software;+ or++(b) for infringements caused by: (i) Your and any other third party's+ modifications of Covered Software, or (ii) the combination of its+ Contributions with other software (except as part of its Contributor+ Version); or++(c) under Patent Claims infringed by Covered Software in the absence of+ its Contributions.++This License does not grant any rights in the trademarks, service marks,+or logos of any Contributor (except as may be necessary to comply with+the notice requirements in Section 3.4).++2.4. Subsequent Licenses++No Contributor makes additional grants as a result of Your choice to+distribute the Covered Software under a subsequent version of this+License (see Section 10.2) or under the terms of a Secondary License (if+permitted under the terms of Section 3.3).++2.5. Representation++Each Contributor represents that the Contributor believes its+Contributions are its original creation(s) or it has sufficient rights+to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use++This License is not intended to limit any rights You have under+applicable copyright doctrines of fair use, fair dealing, or other+equivalents.++2.7. Conditions++Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted+in Section 2.1.++3. Responsibilities+-------------------++3.1. Distribution of Source Form++All distribution of Covered Software in Source Code Form, including any+Modifications that You create or to which You contribute, must be under+the terms of this License. You must inform recipients that the Source+Code Form of the Covered Software is governed by the terms of this+License, and how they can obtain a copy of this License. You may not+attempt to alter or restrict the recipients' rights in the Source Code+Form.++3.2. Distribution of Executable Form++If You distribute Covered Software in Executable Form then:++(a) such Covered Software must also be made available in Source Code+ Form, as described in Section 3.1, and You must inform recipients of+ the Executable Form how they can obtain a copy of such Source Code+ Form by reasonable means in a timely manner, at a charge no more+ than the cost of distribution to the recipient; and++(b) You may distribute such Executable Form under the terms of this+ License, or sublicense it under different terms, provided that the+ license for the Executable Form does not attempt to limit or alter+ the recipients' rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work++You may create and distribute a Larger Work under terms of Your choice,+provided that You also comply with the requirements of this License for+the Covered Software. If the Larger Work is a combination of Covered+Software with a work governed by one or more Secondary Licenses, and the+Covered Software is not Incompatible With Secondary Licenses, this+License permits You to additionally distribute such Covered Software+under the terms of such Secondary License(s), so that the recipient of+the Larger Work may, at their option, further distribute the Covered+Software under the terms of either this License or such Secondary+License(s).++3.4. Notices++You may not remove or alter the substance of any license notices+(including copyright notices, patent notices, disclaimers of warranty,+or limitations of liability) contained within the Source Code Form of+the Covered Software, except that You may alter any license notices to+the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms++You may choose to offer, and to charge a fee for, warranty, support,+indemnity or liability obligations to one or more recipients of Covered+Software. However, You may do so only on Your own behalf, and not on+behalf of any Contributor. You must make it absolutely clear that any+such warranty, support, indemnity, or liability obligation is offered by+You alone, and You hereby agree to indemnify every Contributor for any+liability incurred by such Contributor as a result of warranty, support,+indemnity or liability terms You offer. You may include additional+disclaimers of warranty and limitations of liability specific to any+jurisdiction.++4. Inability to Comply Due to Statute or Regulation+---------------------------------------------------++If it is impossible for You to comply with any of the terms of this+License with respect to some or all of the Covered Software due to+statute, judicial order, or regulation then You must: (a) comply with+the terms of this License to the maximum extent possible; and (b)+describe the limitations and the code they affect. Such description must+be placed in a text file included with all distributions of the Covered+Software under this License. Except to the extent prohibited by statute+or regulation, such description must be sufficiently detailed for a+recipient of ordinary skill to be able to understand it.++5. Termination+--------------++5.1. The rights granted under this License will terminate automatically+if You fail to comply with any of its terms. However, if You become+compliant, then the rights granted under this License from a particular+Contributor are reinstated (a) provisionally, unless and until such+Contributor explicitly and finally terminates Your grants, and (b) on an+ongoing basis, if such Contributor fails to notify You of the+non-compliance by some reasonable means prior to 60 days after You have+come back into compliance. Moreover, Your grants from a particular+Contributor are reinstated on an ongoing basis if such Contributor+notifies You of the non-compliance by some reasonable means, this is the+first time You have received notice of non-compliance with this License+from such Contributor, and You become compliant prior to 30 days after+Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent+infringement claim (excluding declaratory judgment actions,+counter-claims, and cross-claims) alleging that a Contributor Version+directly or indirectly infringes any patent, then the rights granted to+You by any and all Contributors for the Covered Software under Section+2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all+end user license agreements (excluding distributors and resellers) which+have been validly granted by You or Your distributors under this License+prior to termination shall survive termination.++************************************************************************+* *+* 6. Disclaimer of Warranty *+* ------------------------- *+* *+* Covered Software is provided under this License on an "as is" *+* basis, without warranty of any kind, either expressed, implied, or *+* statutory, including, without limitation, warranties that the *+* Covered Software is free of defects, merchantable, fit for a *+* particular purpose or non-infringing. The entire risk as to the *+* quality and performance of the Covered Software is with You. *+* Should any Covered Software prove defective in any respect, You *+* (not any Contributor) assume the cost of any necessary servicing, *+* repair, or correction. This disclaimer of warranty constitutes an *+* essential part of this License. No use of any Covered Software is *+* authorized under this License except under this disclaimer. *+* *+************************************************************************++************************************************************************+* *+* 7. Limitation of Liability *+* -------------------------- *+* *+* Under no circumstances and under no legal theory, whether tort *+* (including negligence), contract, or otherwise, shall any *+* Contributor, or anyone who distributes Covered Software as *+* permitted above, be liable to You for any direct, indirect, *+* special, incidental, or consequential damages of any character *+* including, without limitation, damages for lost profits, loss of *+* goodwill, work stoppage, computer failure or malfunction, or any *+* and all other commercial damages or losses, even if such party *+* shall have been informed of the possibility of such damages. This *+* limitation of liability shall not apply to liability for death or *+* personal injury resulting from such party's negligence to the *+* extent applicable law prohibits such limitation. Some *+* jurisdictions do not allow the exclusion or limitation of *+* incidental or consequential damages, so this exclusion and *+* limitation may not apply to You. *+* *+************************************************************************++8. Litigation+-------------++Any litigation relating to this License may be brought only in the+courts of a jurisdiction where the defendant maintains its principal+place of business and such litigation shall be governed by laws of that+jurisdiction, without reference to its conflict-of-law provisions.+Nothing in this Section shall prevent a party's ability to bring+cross-claims or counter-claims.++9. Miscellaneous+----------------++This License represents the complete agreement concerning the subject+matter hereof. If any provision of this License is held to be+unenforceable, such provision shall be reformed only to the extent+necessary to make it enforceable. Any law or regulation which provides+that the language of a contract shall be construed against the drafter+shall not be used to construe this License against a Contributor.++10. Versions of the License+---------------------------++10.1. New Versions++Mozilla Foundation is the license steward. Except as provided in Section+10.3, no one other than the license steward has the right to modify or+publish new versions of this License. Each version will be given a+distinguishing version number.++10.2. Effect of New Versions++You may distribute the Covered Software under the terms of the version+of the License under which You originally received the Covered Software,+or under the terms of any subsequent version published by the license+steward.++10.3. Modified Versions++If you create software not governed by this License, and you want to+create a new license for such software, you may create and use a+modified version of this License if you rename the license and remove+any references to the name of the license steward (except to note that+such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary+Licenses++If You choose to distribute Source Code Form that is Incompatible With+Secondary Licenses under the terms of this version of the License, the+notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+-------------------------------------------++ This Source Code Form is subject to the terms of the Mozilla Public+ License, v. 2.0. If a copy of the MPL was not distributed with this+ file, You can obtain one at http://mozilla.org/MPL/2.0/.++If it is not possible or desirable to put the notice in a particular+file, then You may include the notice in a location (such as a LICENSE+file in a relevant directory) where a recipient would be likely to look+for such a notice.++You may add additional accurate notices of copyright ownership.++Exhibit B - "Incompatible With Secondary Licenses" Notice+---------------------------------------------------------++ This Source Code Form is "Incompatible With Secondary Licenses", as+ defined by the Mozilla Public License, v. 2.0.
+ README.md view
@@ -0,0 +1,497 @@+# Stan++<p align="center"><img alt="Stan Logo" src="https://user-images.githubusercontent.com/8126674/83521583-59383080-a4d7-11ea-8d9e-33be4677ecb3.png" width=300px height=300px/></p>++[](https://github.com/kowainik/stan/actions)+[](https://hackage.haskell.org/package/stan)+[](https://github.com/kowainik/stan/blob/master/LICENSE)++Stan is a Haskell **ST**atic **AN**alysis tool.++> ⚠️ Note: Stan is in the beta phase. The API is the subject to be+> changed if required by our needs ⚠️++## Table of Contents++ * [What this tool is about](#what-this-tool-is-about)+ * [Goals](#goals)+ * [Features](#features)+ * [How it works](#how-it-works)+ * [Installation instructions](#installation-instructions)+ * [Using Cabal](#using-cabal)+ * [Using Stack](#using-stack)+ * [Usage instructions](#usage-instructions)+ * [General configuration info](#general-configuration-info)+ * [TOML configurations](#toml-configurations)+ * [Command-line Interface](#command-line-interface)+ * [Main command](#main-command)+ * [Inspections](#inspections)+ * [Converting between TOML and CLI configurations](#converting-between-toml-and-cli-configurations)+ * [Roadmap](#roadmap)+ * [Links to Wiki](#links-to-wiki)++## What this tool is about++[[Back to the Table of Contents] ↑](#table-of-contents)++Stan is a command-line tool for analysing Haskell projects and+outputting discovered vulnerabilities in a helpful way with possible+solutions for detected problems. Stan is searching for not only+performance or error-prone code pieces, but it also can help with+establishing and applying best-practices from the whole Haskell+ecosystem.++Although Haskell is a statically typed language, not all properties+can be encoded in types. Even though GHC is quite a powerful compiler,+it tries to be library-agnostic and provide only language-specific+suggestions, while Stan uses the knowledge about the current state of+the ecosystem and commonly used libraries.++You will find Stan helpful if you enjoy writing in Haskell, but want+more guarantees from your code, not provided by the Haskell type+system or GHC.++## Goals++[[Back to the Table of Contents] ↑](#table-of-contents)++Stan design and implementation is driven by the following goals:++- Catch common vulnerabilities, anti-patterns, performance issues+- Provide meaningful insights on the projects generally+- Point out potential bugs and weak points in the programs flow for+ users, so they can carefully evaluate each problem with the code+- Help beginners to learn best practices in an easy and informative way+- Generate the report that can be used as a proof of code quality+- Create best in the class and flexible enough interface for usage+ (including e.g. opt-in and opt-out inspections)++## Features++[[Back to the Table of Contents] ↑](#table-of-contents)++Stan is a configurable CLI tool. Besides the main feature of analysing+Haskell projects statically, Stan has a list of features that make it+unique, easy to use and flexible to configure:++- Pretty analysis results, including both HTML and terminal reports+- Suggestions and possible solutions for fixing the existing problems+- Analysing not only Haskell source code, but also information from+ the `.cabal` files+- Flexible runtime configuration via [TOML][toml] and CLI++You can see an example of Stan HTML report hosted online here:++* [Stan Report Example](https://kowainik.github.io/projects/stan/report)++The below example of the terminal output gives you the understanding+of what sorts of analysis you can expect from Stan:++++## How it works++[[Back to the Table of Contents] ↑](#table-of-contents)++Stan analysis is based on the [HIE files][hie] — compile-time+information about Haskell source code gathered and recorded by+GHC. The HIE files contain the Haskell AST, detailed information about+each identifier and types of all expressions and sub-expressions. GHC+does a huge amount of work when compiling the Haskell projects, and+Stan takes advantage of this feature to avoid duplicating the work and+focus more on the unique features.++To analyse HIE files easily, we developed an eDSL for defining AST and+Type patterns based on the+[_final taggless_](http://okmij.org/ftp/tagless-final/course/lecture.pdf)+approach. Stan algorithm traverses HIE AST for each HIE file in the+project, and matches every AST node with the given pattern to find+potential vulnerabilities in the code.++Each Stan analysis check is represented by the __inspection__ with the+unique ID. Each inspection has a name, description, __severity__, list+of __categories__, pattern for matching relevant parts of source code+and possible solutions to the problem.++When an inspection is casted on the project, it produces zero or more+__observations__ — vulnerabilities in the specific parts of the+code. You can think of an _observation_ as a pair of an inspection and+a piece of source code where this inspection was triggered. Each+observation is assigned an unique stable ID depending on the source+location, so you can refer to them later or ignore.++You can disable inspections or enable them only in particular modules+using __check__ — rules for controlling which inspections to run and+where. Each check has a __type__ (`include` or `exclude`), __filter__+(by inspection id, category, severity, etc.) and __scope__ (file,+directory, everything). Checks can be specified using either TOML of+CLI interfaces. By default, Stan analyses all source files using all+implemented inspections.++If you want to understand Stan terminology better, refer to the+glossary:++ * [Stan Wiki page: Glossary][glossary]++## Installation instructions++[[Back to the Table of Contents] ↑](#table-of-contents)++Stan takes advantage of the+[GHC API](http://hackage.haskell.org/package/ghc) to provide its+analysis. Because of this, Stan and the analysed project need to be+built with the same GHC version (for more details see+[#178](https://github.com/kowainik/stan/issues/178)). That is why the+easiest and most robust way to install Stan is to build it from+sources on your machine.++> __Note:__ Stan is compatible with the GHC versions ⩾ 8.8++### Using Cabal++[[Back to the Table of Contents] ↑](#table-of-contents)++Below are the steps to install Stan using the Cabal build tool.++> You need to have [Cabal ⩾ 2.4](https://www.haskell.org/cabal/)++First, you need to clone the repository:++```shell+$ git clone https://github.com/kowainik/stan.git+$ cd stan+```++Then, you need to build it using Cabal:++```shell+$ cabal v2-build exe:stan+```++Finally, you can copy the resulting executable under the desired+location (that should be under the PATH environment variable), like+so:++```shell+$ cp dist-newstyle/build/x86_64-linux/ghc-8.8.3/stan-0.0.0.0/x/stan/build/stan/stan ~/.local/bin/stan+```++> The path to the executable will be outputted as the last line of the+> previous command.++### Using Stack++[[Back to the Table of Contents] ↑](#table-of-contents)++Below are the steps to install Stan using the Stack build tool.++> You need to have [Stack ⩾ 2.1.3](http://haskellstack.org)++First, you need to clone the repository.++```shell+$ git clone https://github.com/kowainik/stan.git+$ cd stan+```++Then, you need to build it using Stack:++```shell+$ stack build+```++Finally, you can copy the resulting executable under the desired+location (that should be under the PATH environment variable), like+so:++```shell+$ cp "$(stack path --local-install-root)/bin/stan" ~/.local/bin/stan+```++## Usage instructions++[[Back to the Table of Contents] ↑](#table-of-contents)++Stan works with the [HIE files][hie] to analyse Haskell+projects. Therefore, Stan requires users to generate HIE files in+advance. Fortunately, it is straightforward to satisfy this+necessity. To produce HIE files, add the following GHC options in your+project's `.cabal` file to each stanza you want to analyse:++```haskell+ ghc-options: -fwrite-ide-info+ -hiedir=.hie+```++> _Recommendation_: you can use the [common+> stanzas](https://vrom911.github.io/blog/common-stanzas) feature to+> write the above options only once and enable them in each stanza+> easily.++> _Note:_ here we recommend generating the HIE files into `.hie/`+> folder. As it is the recommendation only, you can specify your own+> folder as well. But then you will need to run `stan` using the+> `--hiedir` option with the specified path to your `hie` folder.++After creating HIE files, you can just run Stan on the project:++```shell+$ stan+```++to see all found vulnerabilities in your terminal.++If you want to see a more detailed information in a more structured+way, you can generate an HTML report (to the `stan.html` file) using+the following command:++```shell+$ stan report+```++Stan strives to implement the convenient interface, so you can use the+tool without configuring a lot in advance. However, the tool also+provides various ways to set it up in the way to be the most efficient+with your particular use case.++### General configuration info++[[Back to the Table of Contents] ↑](#table-of-contents)++Stan's work can be configured from the multiple sources (in increasing+order of priority):++1. Default settings (hard-coded in the library — includes __no__+ custom settings)+2. Environment variables+3. [TOML][toml] file configuration+4. CLI arguments++Stan runtime settings have many parts, and each of them can come from+different configuration sources. If some option is specified through+multiple sources, the most prioritized one will be used. In addition,+Stan helps to understand its own configuration, so it outputs detailed+information about each part of the config, what configuration settings+were used and how they were set.++++### TOML configurations++[[Back to the Table of Contents] ↑](#table-of-contents)++Stan supports [TOML][toml] runtime configuration in order to customize+the work of the tool based on the user's individual requirements. You+can use the TOML configuration to disable some inspections, enable+them only in particular Haskell modules, ignore some observations or+completely remove some files from the analysis.++See Haddock documentation for explanation of how the TOML+configuration works and examples of the different use cases.++In case you have a number of TOML files locally, the following rules+describe how Stan decides which TOML configuration file to use:++* By default, Stan tries to read settings from the local `.stan.toml`+ file in the current directory. So, if you want to adjust the default+ Stan settings with some custom rules, create a `.stan.toml` file in+ the root of your Haskell project.+* If the local `.stan.toml` file is not found, Stan tries to read the+ global `~/.stan.toml` file. Having a global Stan configuration can+ be convenient, if you work on several projects and want to have the+ same custom settings by default for all of them.+* If you don't have any of the default configuration files, it is+ still okay. Stan will use its own default hard-coded settings.+* You can specify a path to a specific configuration file using the+ `--config-file` option. This custom file will be used in addition to+ the default TOML config.+* If you don't want to use the default TOML configuration, pass the+ `--no-default` flag or use the `STAN_USE_DEFAULT_CONFIG=False`+ environment variable.++### Command-line Interface++[[Back to the Table of Contents] ↑](#table-of-contents)++This section describes what is possible to achieve with the Stan+CLI. If you have already installed the analyser, you can use++```shell+$ stan --help+```++to get the short information of all possible commands and options in+your terminal.++#### Main command++[[Back to the Table of Contents] ↑](#table-of-contents)++The main command is the one that actually would analyse the Haskell+codebase. There are plenty of configurations and options you can tune+for each run (similarly to the TOML configurations):++- Specify the [HIE files][hie] folder (will use `.hie/` otherwise)+- Specify `.cabal` files of your project (will lookup automatically+ otherwise)+- Turn on/off the usage of the default `.stan.toml` configuration file+- Specify the [TOML][toml] configuration file to use (will be used+ additionally to default TOML file if applicable)+- Filter in or out specific files, directories, inspections,+ categories or severities+- Generate the HTML report file+- Set up the output verbosity++More precisely the commands and options are described in here:++```+stan+ [REPORT]+ [ CHECKs {[TYPE option] [FILTER option] [SCOPE option]}+ | REMOVEs {SCOPE option}+ | IGNOREs {ID option}+ ]+ [--hiedir=DIR_PATH]+ [--cabal-file-path=FILE_PATHs]+ [--config-file=FILE_PATH]+ [--no-default]+ [-s|--short]+ [--hide-solution]+ [-h|--help]+ [-v|--version]++Description:+ CHECKs Command to Specify the list of checks+ REMOVEs Command to Specify scope to be removed+ IGNOREs Command to Specify the list of what needs to be ignored+ REPORT Command to generate an HTML Report+ --hiedir=DIR_PATH Relative path to the directory with HIE+ files (default: .hie)+ --cabal-file-path=FILE_PATHs+ Relative path to the .cabal file (can specify many of this option)+ --config-file=FILE_PATH Relative path to the .toml configurations file+ --no-default Ignore local .stan.toml configuration file+ -s,--short Hide verbose output information for observations+ --hide-solution Hide verbose solution information for observations+ -h,--help Show this help text+ -v,--version Show Stan's version++Sub-commands options:+++ TYPE:+ --include Include check+ --exclude Exclude check+ FILTER:+ --id=INSPECTION_ID Inspection ID to be used+ --severity=SEVERITY Inspection Severity to exclude or include+ --category=CATEGORY Inspection Category to exclude or include+ --filter-all Exclude or include ALL inspections+ SCOPE:+ --file=FILE_PATH File to exclude or include+ --directory=DIRECTORY_PATH+ Directory to exclude or include+ --scope-all Apply check to all files+```++For example, if you want to run Stan analysis only on a single file,+you can use the following command:++```shell+$ stan check --exclude --filter-all --scope-all \+ check --include --filter-all --file=src/Stan/Example.hs+```++#### Inspections++[[Back to the Table of Contents] ↑](#table-of-contents)++You can find the list of all available inspections with description+and additional information on our+[dedicated wiki page][inspections]. However, with the tool you can get+this information easily by using the `inspection` command. Optionally,+you can see details of a particular inspection by typing the+corresponding inspection ID alongside. You can see more robust+description of the command here:++```+inspection – Show all Inspections++Usage:+ stan inspection [INSPECTION_ID]++Available options:+ INSPECTION_ID Show specific Inspection information+ -h,--help Show this help text+```++#### Converting between TOML and CLI configurations++[[Back to the Table of Contents] ↑](#table-of-contents)++It is usually convenient to have a proper configuration file that+suits your project, which you can reuse each run of the Stan.++But sometimes you need to quickly run the tool with the same settings+on another machine where having such files is not possible. Or you+want to send the reproducible command, that anyone could execute and+get the identical results. For these purposes, we have a special+command that allows you to do so:++```+toml-to-cli – Convert TOML configuration file into stan CLI command++Usage:+ stan toml-to-cli [--config-file=FILE_PATH]++Available options:+ --config-file=FILE_PATH Relative path to the .toml configurations file+ -h,--help Show this help text+```++And for convenience you are able to use the reversed command –– `cli-to-toml`.++```+cli-to-toml – Convert CLI arguments into stan TOML configuration++Usage:+ stan cli-to-toml+ [--config-file=FILE_PATH]+ [ CHECKs {[TYPE option] [FILTER option] [SCOPE option]}+ | REMOVEs {SCOPE option}+ | IGNOREs {ID option}+ ]+```++## Roadmap++[[Back to the Table of Contents] ↑](#table-of-contents)++Our plan for the nearest future:++ - [ ] Opt-in inspections+ - [ ] Custom users' inspections+ - [ ] More inspections on potential bugs and performance+ - [ ] Single-pass traverse on AST++We have much more ideas to work on.+See more detailed plan in the dedicated [GitHub Project page](https://github.com/kowainik/stan/projects/1).++## Links to Wiki++[[Back to the Table of Contents] ↑](#table-of-contents)++* [Glossary][glossary]+* [All inspections][inspections]+* [For developers][development]+* [Useful links][links]+* [GHC issues backlog][ghc-backlog]+++[inspections]: https://github.com/kowainik/stan/wiki/All-Inspections+[development]: https://github.com/kowainik/stan/wiki/Development+[ghc-backlog]: https://github.com/kowainik/stan/wiki/GHC-Backlog+[glossary]: https://github.com/kowainik/stan/wiki/Glossary+[links]: https://github.com/kowainik/stan/wiki/Useful-links+[hie]: https://gitlab.haskell.org/ghc/ghc/-/wikis/hie-files+[toml]: https://github.com/toml-lang/toml
+ app/Main.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import Stan (run)+++main :: IO ()+main = run
+ src/Stan.hs view
@@ -0,0 +1,149 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Main running module.+-}++module Stan+ ( run++ -- ** Internal+ , createCabalExtensionsMap+ ) where++import Colourista (errorMessage, formatWith, infoMessage, italic, successMessage, warningMessage)+import System.Directory (doesFileExist, getCurrentDirectory)+import System.Environment (getArgs)+import System.FilePath (takeFileName)+import Trial (Trial (..), prettyTaggedTrial, prettyTrial, prettyTrialWith, trialToMaybe,+ whenResult_)++import Stan.Analysis (Analysis (..), runAnalysis)+import Stan.Analysis.Pretty (prettyShowAnalysis)+import Stan.Cabal (createCabalExtensionsMap, usedCabalFiles)+import Stan.Cli (CliToTomlArgs (..), InspectionArgs (..), StanArgs (..), StanCommand (..),+ TomlToCliArgs (..), runStanCli)+import Stan.Config (ConfigP (..), applyConfig, configToCliCommand, defaultConfig, finaliseConfig)+import Stan.Config.Pretty (prettyConfigCli)+import Stan.Core.Id (Id (..))+import Stan.EnvVars (EnvVars (..), envVarsToText, getEnvVars)+import Stan.Hie (readHieFiles)+import Stan.Hie.Compat (HieFile (..))+import Stan.Info (ProjectInfo (..), StanEnv (..))+import Stan.Inspection (Inspection (..), inspectionsMd, prettyShowInspection,+ prettyShowInspectionShort)+import Stan.Inspection.All (getInspectionById, inspections, lookupInspectionById)+import Stan.Observation (Observation (..), prettyShowIgnoredObservations)+import Stan.Report (generateReport)+import Stan.Severity (Severity (Error))+import Stan.Toml (configCodec, getTomlConfig, usedTomlFiles)++import qualified Toml+++run :: IO ()+run = runStanCli >>= \case+ Stan stanArgs -> runStan stanArgs+ StanInspection inspectionArgs -> runInspection inspectionArgs+ StanTomlToCli tomlToCliArgs -> runTomlToCli tomlToCliArgs+ StanCliToToml cliToTomlArgs -> runCliToToml cliToTomlArgs+ StanInspectionsToMd -> putTextLn $ inspectionsMd inspections++runStan :: StanArgs -> IO ()+runStan StanArgs{..} = do+ -- ENV vars+ env@EnvVars{..} <- getEnvVars+ let defConfTrial = envVarsUseDefaultConfigFile <> stanArgsUseDefaultConfigFile+ infoMessage "Checking environment variables and CLI arguments for default configurations file usage..."+ putTextLn $ indent $ prettyTaggedTrial defConfTrial+ let useDefConfig = maybe True snd (trialToMaybe defConfTrial)+ -- config+ tomlConfig <- getTomlConfig useDefConfig stanArgsConfigFile+ let configTrial = finaliseConfig $ defaultConfig <> tomlConfig <> stanArgsConfig+ infoMessage "The following Configurations are used:\n"+ putTextLn $ indent $ prettyTrialWith (toString . prettyConfigCli) configTrial+ whenResult_ configTrial $ \warnings config -> do+ hieFiles <- readHieFiles stanArgsHiedir+ -- create cabal default extensions map+ cabalExtensionsMap <- createCabalExtensionsMap stanArgsCabalFilePath hieFiles+ -- get checks for each file+ let checksMap = applyConfig (map hie_hs_file hieFiles) config++ let analysis = runAnalysis cabalExtensionsMap checksMap (configIgnored config) hieFiles+ -- show what observations are ignored+ putText $ indent $ prettyShowIgnoredObservations+ (configIgnored config)+ (analysisIgnoredObservations analysis)+ -- show the result+ let observations = analysisObservations analysis+ let isNullObs = null observations+ if isNullObs+ then successMessage "All clean! Stan did not find any observations at the moment."+ else warningMessage "Stan found the following observations for the project:\n"+ putTextLn $ prettyShowAnalysis analysis stanArgsReportSettings++ -- report generation+ when stanArgsReport $ do+ -- Project Info+ piName <- takeFileName <$> getCurrentDirectory+ piCabalFiles <- usedCabalFiles stanArgsCabalFilePath+ let piHieDir = stanArgsHiedir+ let piFileNumber = length hieFiles+ -- Stan Env Info+ seCliArgs <- getArgs+ seTomlFiles <- usedTomlFiles useDefConfig stanArgsConfigFile+ let stanEnv = StanEnv+ { seEnvVars = envVarsToText env+ , ..+ }+ generateReport analysis config warnings stanEnv ProjectInfo{..}+ infoMessage "Report is generated here -> stan.html"++ -- decide on exit status+ when+ ( not isNullObs+ && any ((>= Error) . getObservationSeverity) observations+ )+ exitFailure+ where+ getObservationSeverity :: Observation -> Severity+ getObservationSeverity = inspectionSeverity . getInspectionById . observationInspectionId++ indent :: Text -> Text+ indent = unlines . map (" " <>) . lines++runInspection :: InspectionArgs -> IO ()+runInspection InspectionArgs{..} = case inspectionArgsId of+ Nothing -> for_ inspections (putTextLn . prettyShowInspectionShort)+ Just insId -> case lookupInspectionById insId of+ Just ins -> putTextLn $ prettyShowInspection ins+ Nothing -> do+ errorMessage $ "Inspection with such ID does not exist: " <> unId insId+ putTextLn $ " 💡 " <> formatWith [italic] "Use 'stan inspection' to see the list of all available inspections."++runTomlToCli :: TomlToCliArgs -> IO ()+runTomlToCli TomlToCliArgs{..} = do+ let useDefConfig = isNothing tomlToCliArgsFilePath+ partialConfig <- getTomlConfig useDefConfig tomlToCliArgsFilePath+ case finaliseConfig partialConfig of+ Result _ res -> putTextLn $ configToCliCommand res+ fiasco -> do+ errorMessage "Could not get Configurations:"+ putTextLn $ prettyTrial fiasco++runCliToToml :: CliToTomlArgs -> IO ()+runCliToToml CliToTomlArgs{..} = do+ let toml = Toml.encode configCodec cliToTomlArgsConfig+ case cliToTomlArgsFilePath of+ Nothing -> do+ putTextLn toml+ infoMessage "Copy-paste the above TOML into .stan.toml and stan will pick up this file on the next run"+ Just path -> do+ isFile <- doesFileExist path+ if isFile+ then errorMessage $ "Aborting writing to file because it already exists: " <> toText path+ else do+ writeFileText path toml+ infoMessage $ "TOML configuration is written to file: " <> toText path
+ src/Stan/Analysis.hs view
@@ -0,0 +1,182 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Static analysis of all HIE files.+-}++module Stan.Analysis+ ( Analysis (..)+ , runAnalysis+ ) where++import Extensions (ExtensionsError (..), OnOffExtension, ParsedExtensions (..),+ SafeHaskellExtension, parseSourceWithPath)+import Relude.Extra.Lens (Lens', lens, over)++import Stan.Analysis.Analyser (analysisByInspection)+import Stan.Cabal (mergeParsedExtensions)+import Stan.Core.Id (Id)+import Stan.Core.ModuleName (fromGhcModule)+import Stan.FileInfo (FileInfo (..), FileMap)+import Stan.Hie (countLinesOfCode)+import Stan.Hie.Compat (HieFile (..))+import Stan.Inspection (Inspection)+import Stan.Inspection.All (lookupInspectionById)+import Stan.Observation (Observation (..), Observations)++import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Slist as S+++{- | This data type stores all information collected during static analysis.+-}+data Analysis = Analysis+ { analysisModulesNum :: !Int+ , analysisLinesOfCode :: !Int+ , analysisUsedExtensions :: !(Set OnOffExtension, Set SafeHaskellExtension)+ , analysisInspections :: !(HashSet (Id Inspection))+ , analysisObservations :: !Observations+ , analysisIgnoredObservations :: !Observations+ , analysisFileMap :: !FileMap+ } deriving stock (Show)++modulesNumL :: Lens' Analysis Int+modulesNumL = lens+ analysisModulesNum+ (\analysis new -> analysis { analysisModulesNum = new })++linesOfCodeL :: Lens' Analysis Int+linesOfCodeL = lens+ analysisLinesOfCode+ (\analysis new -> analysis { analysisLinesOfCode = new })++extensionsL :: Lens' Analysis (Set OnOffExtension, Set SafeHaskellExtension)+extensionsL = lens+ analysisUsedExtensions+ (\analysis new -> analysis { analysisUsedExtensions = new })++inspectionsL :: Lens' Analysis (HashSet (Id Inspection))+inspectionsL = lens+ analysisInspections+ (\analysis new -> analysis { analysisInspections = new })++observationsL :: Lens' Analysis Observations+observationsL = lens+ analysisObservations+ (\analysis new -> analysis { analysisObservations = new })++ignoredObservationsL :: Lens' Analysis Observations+ignoredObservationsL = lens+ analysisIgnoredObservations+ (\analysis new -> analysis { analysisIgnoredObservations = new })++fileMapL :: Lens' Analysis FileMap+fileMapL = lens+ analysisFileMap+ (\analysis new -> analysis { analysisFileMap = new })++initialAnalysis :: Analysis+initialAnalysis = Analysis+ { analysisModulesNum = 0+ , analysisLinesOfCode = 0+ , analysisUsedExtensions = mempty+ , analysisInspections = mempty+ , analysisObservations = mempty+ , analysisIgnoredObservations = mempty+ , analysisFileMap = mempty+ }++incModulesNum :: State Analysis ()+incModulesNum = modify' $ over modulesNumL (+ 1)++{- | Increase the total loc ('analysisLinesOfCode') by the given number of+analised lines of code.+-}+incLinesOfCode :: Int -> State Analysis ()+incLinesOfCode num = modify' $ over linesOfCodeL (+ num)++-- | Add set of 'Inspection' 'Id's to the existing set.+addInspections :: HashSet (Id Inspection) -> State Analysis ()+addInspections ins = modify' $ over inspectionsL (ins <>)++-- | Add list of 'Observation's to the beginning of the existing list+addObservations :: Observations -> State Analysis ()+addObservations observations = modify' $ over observationsL (observations <>)++-- | Add list of 'Observation's to the beginning of the existing list+addIgnoredObservations :: Observations -> State Analysis ()+addIgnoredObservations obs = modify' $ over ignoredObservationsL (obs <>)++-- | Collect all unique used extensions.+addExtensions :: ParsedExtensions -> State Analysis ()+addExtensions ParsedExtensions{..} = modify' $ over extensionsL+ (\(setExts, setSafeExts) ->+ ( Set.union (Set.fromList parsedExtensionsAll) setExts+ , maybe setSafeExts (`Set.insert` setSafeExts) parsedExtensionsSafe+ )+ )++-- | Update 'FileInfo' for the given 'FilePath'.+updateFileMap :: FilePath -> FileInfo -> State Analysis ()+updateFileMap fp fi = modify' $ over fileMapL (Map.insert fp fi)++{- | Perform static analysis of given 'HieFile'.+-}+runAnalysis+ :: Map FilePath (Either ExtensionsError ParsedExtensions)+ -> HashMap FilePath (HashSet (Id Inspection))+ -> [Id Observation] -- ^ List of to-be-ignored Observations.+ -> [HieFile]+ -> Analysis+runAnalysis cabalExtensionsMap checksMap obs = executingState initialAnalysis .+ analyse cabalExtensionsMap checksMap obs++analyse+ :: Map FilePath (Either ExtensionsError ParsedExtensions)+ -> HashMap FilePath (HashSet (Id Inspection))+ -> [Id Observation] -- ^ List of to-be-ignored Observations.+ -> [HieFile]+ -> State Analysis ()+analyse _extsMap _checksMap _observations [] = pass+analyse cabalExtensions checksMap observations (hieFile@HieFile{..}:hieFiles) = do+ whenJust (HM.lookup hie_hs_file checksMap)+ (analyseHieFile hieFile cabalExtensions observations)+ analyse cabalExtensions checksMap observations hieFiles++analyseHieFile+ :: HieFile+ -> Map FilePath (Either ExtensionsError ParsedExtensions)+ -> [Id Observation] -- ^ List of to-be-ignored Observations.+ -> HashSet (Id Inspection)+ -> State Analysis ()+analyseHieFile hieFile@HieFile{..} cabalExts obs insIds = do+ -- traceM (hie_hs_file hieFile)+ let fileInfoLoc = countLinesOfCode hieFile+ let fileInfoCabalExtensions = fromMaybe+ (Left $ NotCabalModule hie_hs_file)+ (Map.lookup hie_hs_file cabalExts)+ let fileInfoExtensions = first (ModuleParseError hie_hs_file) $+ parseSourceWithPath hie_hs_file hie_hs_src+ let fileInfoPath = hie_hs_file+ let fileInfoModuleName = fromGhcModule hie_module+ -- merge cabal and module extensions and update overall exts+ let fileInfoMergedExtensions = mergeParsedExtensions fileInfoCabalExtensions fileInfoExtensions+ -- get list of inspections for the file+ let ins = mapMaybe lookupInspectionById (toList insIds)+ let allObservations = S.concatMap+ (\iId -> analysisByInspection fileInfoMergedExtensions iId hieFile)+ ins+ let (ignoredObs, fileInfoObservations) = S.partition ((`elem` obs) . observationId) allObservations++ incModulesNum+ incLinesOfCode fileInfoLoc+ updateFileMap hie_hs_file FileInfo{..}+ whenRight_ fileInfoExtensions addExtensions+ whenRight_ fileInfoCabalExtensions addExtensions+ addInspections insIds+ addObservations fileInfoObservations+ addIgnoredObservations ignoredObs
+ src/Stan/Analysis/Analyser.hs view
@@ -0,0 +1,409 @@+{-# LANGUAGE BangPatterns #-}++{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Analysing functions by 'InspectionAnalysis' for the corresponding+'Inspection'.+-}++module Stan.Analysis.Analyser+ ( analysisByInspection+ ) where++import Extensions (ExtensionsResult)+import GHC.LanguageExtensions.Type (Extension (Strict, StrictData))+import Slist (Slist, slist)++import Stan.Core.Id (Id)+import Stan.Core.List (nonRepeatingPairs)+import Stan.FileInfo (isExtensionDisabled)+import Stan.Ghc.Compat (RealSrcSpan, isSymOcc, nameOccName, occNameString)+import Stan.Hie (eqAst)+import Stan.Hie.Compat (HieAST (..), HieASTs (..), HieFile (..), Identifier, NodeInfo (..),+ TypeIndex)+import Stan.Hie.MatchAst (hieMatchPatternAst)+import Stan.Inspection (Inspection (..), InspectionAnalysis (..))+import Stan.NameMeta (NameMeta, ghcPrimNameFrom)+import Stan.Observation (Observations, mkObservation)+import Stan.Pattern.Ast (Literal (..), PatternAst (..), anyNamesToPatternAst, case', constructor,+ dataDecl, fixity, fun, guardBranch, lambdaCase, lazyField, literalPat,+ opApp, patternMatchArrow, patternMatchBranch, patternMatch_, rhs, tuple,+ typeSig)+import Stan.Pattern.Edsl (PatternBool (..))++import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Slist as S+++{- | Create analysing function for 'Inspection' by pattern-matching+over 'InspectionAnalysis'.+-}+analysisByInspection+ :: ExtensionsResult+ -> Inspection+ -> HieFile+ -> Observations+analysisByInspection exts Inspection{..} = case inspectionAnalysis of+ FindAst patAst -> analyseAst inspectionId patAst+ Infix -> analyseInfix inspectionId+ LazyField -> memptyIfFalse+ (isExtensionDisabled StrictData exts && isExtensionDisabled Strict exts)+ (analyseLazyFields inspectionId)+ BigTuples -> analyseBigTuples inspectionId+ PatternMatchOn_ -> analysePatternMatch_ inspectionId+ UseCompare -> analyseCompare inspectionId++{- | Check for occurrences of the specified function given via 'NameMeta'.+-}+analyseAst+ :: Id Inspection+ -> PatternAst+ -> HieFile+ -> Observations+analyseAst insId patAst hie =+ mkObservation insId hie <$> analyseAstWith (createMatch patAst hie) hie++{- | Check for big tuples (size >= 4) in the following places:++* Type signatures: foo :: (Int, Int, Int, Int)+* Literals: (True, 0, [], Nothing)+-}+analyseBigTuples+ :: Id Inspection+ -> HieFile+ -> Observations+analyseBigTuples insId hie =+ S.map (mkObservation insId hie . nodeSpan)+ $ S.filter isBigTuple+ $ analyseAstWith (createMatchAst tuple hie) hie+ where+ isBigTuple :: HieAST TypeIndex -> Bool+ isBigTuple Node{..} = case nodeChildren of+ _:_:_:_:_ -> True+ _lessThan4 -> False++{- | Find usages of multiple comparison operators and suggest using+'compare'. Currently, handles the following cases:++* Guards++The algorithm is to find all guards, filter them by usage of+comparison operators and find matches.+-}+analyseCompare+ :: Id Inspection+ -> HieFile+ -> Observations+analyseCompare insId hie =+ mkObservation insId hie <$> analyseAstWith matchComparisonGuards hie+ where+ matchComparisonGuards :: HieAST TypeIndex -> Slist RealSrcSpan+ matchComparisonGuards node = memptyIfFalse+ (hieMatchPatternAst hie node fun)+ $ let guards = mapMaybe extractComparisonGuard (nodeChildren node)+ in memptyIfFalse (hasManyCompares guards) (S.one $ nodeSpan node)++ {- Extract left argument, name of a comparison operator and right+ argument from a guard.+ -}+ extractComparisonGuard+ :: HieAST TypeIndex+ -> Maybe (HieAST TypeIndex, HieAST TypeIndex)+ extractComparisonGuard node = do+ -- guard starts with GRHS annotation+ guard $ hieMatchPatternAst hie node rhs+ -- guard predicate is a first son+ stmt:_ <- Just $ nodeChildren node+ -- check if it's a guard+ guard $ hieMatchPatternAst hie stmt guardBranch+ -- check if it's an operator+ guard $ hieMatchPatternAst hie stmt $ opApp (?) opsPat (?)+ -- extract comparison+ x:_opAst:y:_ <- Just $ nodeChildren stmt+ pure (x, y)++ -- pattern for any comparison operator+ opsPat :: PatternAst+ opsPat = anyNamesToPatternAst $ le :| [leq, eq, ge, geq]++ le, leq, eq, ge, geq :: NameMeta+ le = opName "<"+ leq = opName "<="+ eq = opName "=="+ ge = opName ">"+ geq = opName ">="++ opName :: Text -> NameMeta+ opName = (`ghcPrimNameFrom` "GHC.Classes")++ -- return True if any two pairs perform comparison of similar things+ hasManyCompares :: [(HieAST TypeIndex, HieAST TypeIndex)] -> Bool+ hasManyCompares = any (uncurry matchingComparions) . nonRepeatingPairs++ matchingComparions+ :: (HieAST TypeIndex, HieAST TypeIndex)+ -> (HieAST TypeIndex, HieAST TypeIndex)+ -> Bool+ matchingComparions (a, b) (x, y) =+ (eqAst hie a x && eqAst hie b y) || (eqAst hie a y && eqAst hie b x)+++{- | Check for occurrences lazy fields in all constructors. Ignores+@newtype@s. Currently HIE Ast doesn't have information whether the+data type is @newtype@ or not. So the algorithm ignores all data types+with a single constructor and single field inside that constructor.+-}+analyseLazyFields+ :: Id Inspection+ -> HieFile+ -> Observations+analyseLazyFields insId hie =+ mkObservation insId hie <$> analyseAstWith matchLazyField hie+ where+ matchLazyField :: HieAST TypeIndex -> Slist RealSrcSpan+ matchLazyField node = memptyIfFalse+ -- return empty list if it's not a data type+ (hieMatchPatternAst hie node dataDecl)+ -- get list of all constructors+ $ let constructors = filter+ (\n -> hieMatchPatternAst hie n constructor)+ (nodeChildren node)+ in case constructors of+ -- no constructors = not observations+ [] -> mempty+ -- single constructor+ [c] -> S.concatMap matchField $ extractFields False c+ -- multiple constructors = analyse everything+ cs -> S.concatMap (S.concatMap matchField . extractFields True) cs++ -- Extract fields as AST nodes. Return empty list if only one field+ -- (as a workaround for the @newtype@ problem)+ --+ -- record constructors have 2 children:+ -- 1. Constructor name.+ -- 2. Dummy child with all fields as childrens+ -- plain constructors have constructor name and children in the same list+ extractFields :: Bool -> HieAST TypeIndex -> [HieAST TypeIndex]+ extractFields hasManyCtors ctor = case drop 1 $ nodeChildren ctor of+ [] -> [] -- no fields+ [n] -> -- single field, maybe dummy record node+ if isDummyRecordNode n+ then case nodeChildren n of+ [] -> []+ [field] -> [field | hasManyCtors]+ fields -> fields+ else [n | hasManyCtors]+ fields -> fields -- plain constructor+ where+ -- simple check for the dummy AST node+ isDummyRecordNode :: HieAST TypeIndex -> Bool+ isDummyRecordNode = Set.null . nodeAnnotations . nodeInfo++ -- matches record fields non-recursively+ matchField :: HieAST TypeIndex -> Slist RealSrcSpan+ matchField = createMatch lazyField hie++{- | Check for occurrences of pattern matching on @_@ for sum types (except+literals).+-}+analysePatternMatch_ :: Id Inspection -> HieFile -> Observations+analysePatternMatch_ insId hie =+ mkObservation insId hie <$> analyseAstWith matchPatternMatch hie+ where+ matchPatternMatch :: HieAST TypeIndex -> Slist RealSrcSpan+ matchPatternMatch node = memptyIfFalse+ -- return empty list if it's not a case or lambda case+ (hieMatchPatternAst hie node $ lambdaCase ||| case')+ -- get list of all case branches+ $ case nodeChildren node of+ -- no branches = not observations+ [] -> mempty+ -- lambda case, first kid is pattern matching+ [pm] -> analyseBranches pm+ -- case, first kid is @case exp of@, the second is pattern matching+ _:pm:_ -> analyseBranches pm++ {- Check the pattern matching child on some particular expressions.++ -}+ analyseBranches :: HieAST TypeIndex -> Slist RealSrcSpan+ analyseBranches pm = case nodeChildren pm of+ -- if there is no children = no observations+ [] -> mempty+ -- we need to check first and all other children separately+ -- see 'isFirstPatternMatchBranchOk' comment to understand the first+ -- child's rules.+ c:cs -> memptyIfFalse (isFirstPatternMatchBranchOk c) $+ {- if the first child satisfies rules of the first pattern matching+ branch, then we need to find the child with pattern matching on @_@.+ If there is no such expression = all is good.+ -}+ case find (\x -> hieMatchPatternAst hie x (patternMatch_ (?))) cs of+ Nothing -> mempty+ Just e -> S.one (nodeSpan e)++ {- The first pattern matching branch should not:+ 1. Be empty (makes no sense)+ 2. Be a literal pattern matching (e.g. on 'Int's or 'String's)+ In all other cases we can continue our matching checks with other children.+ -}+ isFirstPatternMatchBranchOk :: HieAST TypeIndex -> Bool+ isFirstPatternMatchBranchOk c = hieMatchPatternAst hie c patternMatchBranch &&+ case takeWhile isNotMatchArrow $ nodeChildren c of+ [] -> False+ [x] -> hieMatchPatternAst hie x notLiteral+ _:_ -> True+ where+ isNotMatchArrow :: HieAST TypeIndex -> Bool+ isNotMatchArrow n = hieMatchPatternAst hie n $ neg $ patternMatchArrow (?)++ notLiteral :: PatternAst+ notLiteral = neg+ -- general literal expression+ ( PatternAstConstant AnyLiteral+ -- since GHC-8.10 expression for literal in pattern matching+ ||| literalPat+ )++{- | Analyse HIE AST to find all operators which lack explicit fixity+declaration.++The algorithm is the following:++1. Traverse AST and discover all top-level operators and @infix@+declarations in a single pass.+2. Compare two resulting sets to find out operators without @infix@+declaration.+-}+analyseInfix+ :: Id Inspection+ -> HieFile+ -> Observations+analyseInfix insId hie =+ let opDecls = analyseAstWith (matchInfix <> matchOperator) hie+ (fixities, topOperators) = partitionDecls opDecls+ operatorsWithoutFixity = HM.difference topOperators fixities+ in mkObservation insId hie <$> slist (toList operatorsWithoutFixity)+ where+ -- returns list of operator names defined in a single fixity declaration:+ -- infix 5 ***, +++, ???+ matchInfix :: HieAST TypeIndex -> Slist OperatorDecl+ matchInfix node@Node{..} = memptyIfFalse+ (hieMatchPatternAst hie node fixity)+ (S.concatMap nodeIds nodeChildren)++ -- singleton or empty list with the top-level operator definition+ matchOperator :: HieAST TypeIndex -> Slist OperatorDecl+ matchOperator node@Node{..} = memptyIfFalse+ (hieMatchPatternAst hie node typeSig)+ (maybeToMonoid $ viaNonEmpty (extractOperatorName . head) nodeChildren)+ -- first child of a parent is a name of a function/operator++ -- return AST node identifier names as a sized list of texts+ nodeIds :: HieAST TypeIndex -> Slist OperatorDecl+ nodeIds =+ S.concatMap identifierName+ . Map.keys+ . nodeIdentifiers+ . nodeInfo++ identifierName :: Identifier -> Slist OperatorDecl+ identifierName = \case+ Left _ -> mempty+ Right name -> S.one $ Fixity $ toText $ occNameString $ nameOccName name++ extractOperatorName :: HieAST TypeIndex -> Slist OperatorDecl+ extractOperatorName Node{..} =+ S.concatMap (topLevelOperatorName nodeSpan)+ $ Map.keys+ $ nodeIdentifiers nodeInfo++ topLevelOperatorName :: RealSrcSpan -> Identifier -> Slist OperatorDecl+ topLevelOperatorName srcSpan = \case+ Left _ -> mempty+ Right name ->+ let occName = nameOccName name+ in memptyIfFalse+ (isSymOcc occName) -- check if operator+ (S.one $ Operator (toText $ occNameString occName) srcSpan)++-- | Either top-level operator or fixity declaration+data OperatorDecl+ = Fixity !Text+ -- | Operator name with its position to display later+ | Operator !Text !RealSrcSpan++{- | Partition a foldable of operator declarations into two maps:++1. Fixity declarations (mapped to @()@).+2. Top-level operator names (mapped to their source positions.++'Map' is used to be able to use the nice @merge@ function.+-}+partitionDecls+ :: Foldable f+ => f OperatorDecl+ -> (HashMap Text (), HashMap Text RealSrcSpan)+partitionDecls = foldl' insertDecl mempty+ where+ insertDecl+ :: (HashMap Text (), HashMap Text RealSrcSpan)+ -> OperatorDecl+ -> (HashMap Text (), HashMap Text RealSrcSpan)+ insertDecl (!fixities, !topOperators) = \case+ Fixity name -> (HM.insert name () fixities, topOperators)+ Operator name srcSpan -> (fixities, HM.insert name srcSpan topOperators)++{- | Analyses the whole AST starting from the very top.+-}+analyseAstWith+ :: forall a+ . (HieAST TypeIndex -> Slist a)+ -- ^ Function to match AST node to some arbitrary type and return a+ -- sized list of matched elements+ -> HieFile+ -> Slist a+analyseAstWith match = findNodes . hie_asts+ where+ findNodes :: HieASTs TypeIndex -> Slist a+ findNodes =+ S.concatMap (matchAstWith match)+ . Map.elems+ . getAsts++{- | Recursively match AST nodes starting from a given AST.+-}+matchAstWith+ :: forall a+ . (HieAST TypeIndex -> Slist a)+ -- ^ Function to match AST node to some arbitrary type and return a+ -- sized list of matched elements+ -> HieAST TypeIndex+ -> Slist a+matchAstWith match = matchAst+ where+ matchAst :: HieAST TypeIndex -> Slist a+ matchAst node@Node{..} =+ match node <> S.concatMap matchAst nodeChildren++-- | Like 'createMatchAst' but returns source spans of AST nodes.+createMatch :: PatternAst -> HieFile -> (HieAST TypeIndex -> Slist RealSrcSpan)+createMatch patAst hie = fmap nodeSpan . createMatchAst patAst hie++{- | Create a non-recursive matching function for 'PatternAst' that+returns sized list of nodes that match this pattern.++* If the pattern matches 'Node', return it+* Otherwise return empty list+-}+createMatchAst+ :: PatternAst+ -> HieFile+ -> (HieAST TypeIndex -> Slist (HieAST TypeIndex))+createMatchAst patAst hie node =+ memptyIfFalse (hieMatchPatternAst hie node patAst) (S.one node)
+ src/Stan/Analysis/Pretty.hs view
@@ -0,0 +1,174 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Pretty printing of Stan's analysis.+-}++module Stan.Analysis.Pretty+ ( prettyShowAnalysis++ -- * Numbers+ , AnalysisNumbers (..)+ , ProjectHealth (..)+ , analysisToNumbers+ , prettyHealth+ , toProjectHealth+ ) where++import Colourista.Short (b, i)+import Extensions (ExtensionsError, ParsedExtensions)+import Text.Printf (printf)++import Stan.Analysis (Analysis (..))+import Stan.Core.ModuleName (ModuleName (..))+import Stan.FileInfo (FileInfo (..), extensionsToText)+import Stan.Observation (Observation (..), prettyShowObservation)+import Stan.Report.Settings (ReportSettings (..), Verbosity (..))++import qualified Data.HashSet as HS+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified Slist as S+++{- | Shows analysed output of Stan work.+This functions groups 'Observation's by 'FilePath' they are found in.+-}+prettyShowAnalysis :: Analysis -> ReportSettings -> Text+prettyShowAnalysis an rs@ReportSettings{..} = case reportSettingsVerbosity of+ Verbose -> groupedObservations <> summary (analysisToNumbers an)+ NonVerbose -> unlines $ toList $ prettyShowObservation rs <$> analysisObservations an+ where+ groupedObservations :: Text+ groupedObservations =+ Text.intercalate "\n\n"+ $ filter (/= "")+ $ map (showByFile rs)+ $ Map.elems+ $ analysisFileMap an++data AnalysisNumbers = AnalysisNumbers+ { anModules :: !Int+ , anLoc :: !Int+ , anExts :: !Int+ , anSafeExts :: !Int+ , anIns :: !Int+ , anFoundObs :: !Int+ , anIgnoredObs :: !Int+ , anHealth :: !Double+ }++analysisToNumbers :: Analysis -> AnalysisNumbers+analysisToNumbers Analysis{..} = AnalysisNumbers+ { anModules = analysisModulesNum+ , anLoc = analysisLinesOfCode+ , anExts = Set.size $ fst analysisUsedExtensions+ , anSafeExts = Set.size $ snd analysisUsedExtensions+ , anIns = HS.size analysisInspections+ , anFoundObs = length analysisObservations+ , anIgnoredObs = length analysisIgnoredObservations+ , anHealth = calculatedHealth+ }+ where+ calculatedHealth :: Double+ calculatedHealth =+ -- all inspections ignored or no observations+ if null analysisInspections || null analysisObservations+ then 100+ else+ let totalInspections = fromIntegral $ HS.size analysisInspections+ triggeredInspections =+ fromIntegral+ $ Set.size+ $ Set.fromList+ $ map observationInspectionId+ $ toList analysisObservations++ in 100 * (1 - triggeredInspections / totalInspections)++{- | Show project health as pretty text with 2 digits after dot.+-}+prettyHealth :: Double -> Text+prettyHealth health =+ if fromIntegral (floor health :: Int) == health -- display without decimal part+ then toText (printf "%.0f" health :: String) <> "%"+ else toText (printf "%.2f" health :: String) <> "%"++{- | Enum to describe project health depending on the value of+'anHealth'.+-}+data ProjectHealth+ = Unhealthy+ | LowHealth+ | MediumHealth+ | Healthy++-- | Calculate 'ProjectHealth'.+toProjectHealth :: Double -> ProjectHealth+toProjectHealth health+ | health >= 100 = Healthy+ | health >= 80 = MediumHealth+ | health >= 40 = LowHealth+ | otherwise = Unhealthy++summary :: AnalysisNumbers -> Text+summary AnalysisNumbers{..} = unlines+ [ ""+ , b " Stan's Summary:"+ , top+ , alignText "Analysed modules" <> alignNum anModules+ , mid+ , alignText "Analysed Lines of Code" <> alignNum anLoc+ , mid+ , alignText "Total Haskel2010 extensions" <> alignNum anExts+ , mid+ , alignText "Total SafeHaskel extensions" <> alignNum anSafeExts+ , mid+ , alignText "Total checked inspections" <> alignNum anIns+ , mid+ , alignText "Total found observations" <> alignNum anFoundObs+ , mid+ , alignText "Total ignored observations" <> alignNum anIgnoredObs+ , mid+ , alignText "Project health" <> alignVal (prettyHealth anHealth)+ , bot+ ]+ where+ alignNum :: Int -> Text+ alignNum = alignVal . show++ alignVal :: Text -> Text+ alignVal x = " ┃ " <> Text.justifyLeft 6 ' ' x <> " ┃"++ alignText :: Text -> Text+ alignText txt ="┃ " <> Text.justifyLeft 27 ' ' txt++ separator :: Text -> Text -> Text -> Text+ separator l c r = l <> Text.replicate 29 "━" <> c <> Text.replicate 8 "━" <> r+ top, mid, bot :: Text+ top = separator "┏" "┳" "┓"+ mid = separator "┣" "╋" "┫"+ bot = separator "┗" "┻" "┛"++showByFile :: ReportSettings -> FileInfo -> Text+showByFile reportSettings FileInfo{..} = if len == 0 then "" else unlines+ [ i " File: " <> b (toText fileInfoPath)+ , i " Module: " <> b (unModuleName fileInfoModuleName)+ , i " LoC: " <> b (show fileInfoLoc)+ , i " Observations: " <> b (show len)+ , i " Extensions from .cabal: " <> b (showExts fileInfoCabalExtensions)+ , i " Extensions from module: " <> b (showExts fileInfoExtensions)+ , " ┏" <> Text.replicate 78 "━"+ ]++ <> Text.intercalate (" ┃\n ┃" <> Text.replicate 78 "~" <> "\n ┃\n")+ (toList $ prettyShowObservation reportSettings <$> S.sortOn observationLoc fileInfoObservations)+ where+ len :: Int+ len = length fileInfoObservations++ showExts :: Either ExtensionsError ParsedExtensions -> Text+ showExts = Text.intercalate ", " . extensionsToText
+ src/Stan/Analysis/Summary.hs view
@@ -0,0 +1,97 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Static analysis summary.+-}++module Stan.Analysis.Summary+ ( Summary (..)+ , createSummary+ ) where++import Stan.Analysis (Analysis (..))+import Stan.Category (Category)+import Stan.Core.Id (Id)+import Stan.Core.ModuleName (ModuleName)+import Stan.Inspection (Inspection (..))+import Stan.Inspection.All (getInspectionById)+import Stan.Observation (Observation (..))+import Stan.Severity (Severity)++import qualified Data.HashMap.Strict as HM+++-- | Short info about analysis.+data Summary = Summary+ { summaryInspectionId :: !(Id Inspection) -- ^ The most popular 'Inspection'+ , summaryCategory :: !Category -- ^ The most popular 'Category'+ , summaryModule :: !ModuleName -- ^ Module with the biggest number of observations+ , summarySeverity :: !Severity -- ^ The highest 'Severity'+ }++data SummaryData = SummaryData+ { sdInspections :: !(HashMap (Id Inspection) Int) -- ^ Count of each inspection+ , sdCategories :: !(HashMap Category Int) -- ^ Count of each category+ , sdModules :: !(HashMap ModuleName Int) -- ^ Count of observations per module+ , sdSeverity :: !(Maybe Severity) -- ^ Highest severity+ }++emptySummaryData :: SummaryData+emptySummaryData = SummaryData+ { sdInspections = mempty+ , sdCategories = mempty+ , sdModules = mempty+ , sdSeverity = Nothing+ }++summaryFromData :: SummaryData -> Maybe Summary+summaryFromData SummaryData{..} = do+ summaryInspectionId <- maxOnSnd $ HM.toList sdInspections+ summaryCategory <- maxOnSnd $ HM.toList sdCategories+ summaryModule <- maxOnSnd $ HM.toList sdModules+ summarySeverity <- sdSeverity+ pure Summary{..}+ where+ maxOnSnd :: Ord b => [(a, b)] -> Maybe a+ maxOnSnd = viaNonEmpty (fst . maximumOn1 snd)++{- | Assemble 'Summary' after analysis. Returns 'Nothing' when there's+no 'Observations'. Otherwise, there's at least one observation, which+means that we can find the most popular 'Inspection', 'Category' and+the highest 'Severity'.+-}+createSummary :: Analysis -> Maybe Summary+createSummary Analysis{..} = summaryFromData+ $ foldl' handleObservation emptySummaryData analysisObservations+ where+ handleObservation :: SummaryData -> Observation -> SummaryData+ handleObservation SummaryData{..} Observation{..} =+ let Inspection{..} = getInspectionById observationInspectionId+ in SummaryData+ -- increase count for the current observations+ { sdInspections = HM.insertWith (+) observationInspectionId 1 sdInspections++ -- increase count for each category+ , sdCategories = flipfoldl'+ (\cat -> HM.insertWith (+) cat 1)+ sdCategories+ inspectionCategory++ -- increase count the module+ , sdModules = HM.insertWith (+) observationModuleName 1 sdModules++ -- choose the highest severity+ , sdSeverity = max sdSeverity (Just inspectionSeverity)+ }++-- | Fast, strict maximum+maximumOn1 :: forall b a . Ord b => (a -> b) -> NonEmpty a -> a+maximumOn1 f (x :| xs) = foldl' cmp x xs+ where+ cmp :: a -> a -> a+ cmp a b = case compare (f a) (f b) of+ LT -> b+ EQ -> a+ GT -> a
+ src/Stan/Cabal.hs view
@@ -0,0 +1,132 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Functions to work with cabal files and cabal extension maps.+-}++module Stan.Cabal+ ( createCabalExtensionsMap+ , usedCabalFiles++ , mergeParsedExtensions+ ) where++import Relude.Extra.Tuple (toSnd)++import Colourista (errorMessage, infoMessage, warningMessage)+import Control.Exception (catch)+import Extensions (CabalException, ExtensionsError (..), ExtensionsResult, ParsedExtensions (..),+ mergeAnyExtensions, parseCabalFileExtensions)+import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, listDirectory,+ makeRelativeToCurrentDirectory)+import System.FilePath (takeExtension, (</>))+import System.IO.Unsafe (unsafeInterleaveIO)++import Stan.Hie.Compat (HieFile (..))++import qualified Data.Map.Strict as Map+++{- | Gets the list of @.cabal@ file paths that were used in the project.+-}+usedCabalFiles :: [FilePath] -> IO [FilePath]+usedCabalFiles fs = do+ cabals <- case fs of+ [] -> findCabalFiles+ files -> pure files+ mapM makeRelativeToCurrentDirectory cabals++{- | From a given path to cabal files and 'HieFile's create the map from modules+(that are in .cabal file) to the resulting parsed extensions for each.+-}+createCabalExtensionsMap+ :: [FilePath] -- ^ @.cabal@ files+ -> [HieFile]+ -> IO (Map FilePath (Either ExtensionsError ParsedExtensions))+createCabalExtensionsMap cabalPath hies = case cabalPath of+ -- if cabal files are not specified via CLI option+ -- try to find cabal files in current directory+ [] -> findCabalFiles >>= \case+ -- if cabal file is not found, pass the empty map instead+ [] -> do+ warningMessage ".cabal file not found in the current directory."+ infoMessage " 💡 Try using --cabal-file-path option to specify the path to the .cabal file.\n"+ pure mempty+ -- else concat map for each @.cabal@ file.+ cabals -> mconcat <$> mapM getExtensionsWithCabal cabals+ -- if cabal file specified via CLI option+ cabals -> fmap mconcat $ forM (ordNub cabals) $ \cabal ->+ ifM (doesFileExist cabal)+ {- then -} (getExtensionsWithCabal cabal)+ {- else -} (errorMessage (".cabal file does not exist: " <> toText cabal) >> exitFailure)+ where+ getExtensionsWithCabal+ :: FilePath+ -> IO (Map FilePath (Either ExtensionsError ParsedExtensions))+ getExtensionsWithCabal cabal = do+ infoMessage $ "Using the following .cabal file: " <> toText cabal <> "\n"+ (Right <<$>> parseCabalFileExtensions cabal)+ `catch` handleCabalErr+ where+ handleCabalErr+ :: CabalException+ -> IO (Map FilePath (Either ExtensionsError ParsedExtensions))+ handleCabalErr err = do+ errorMessage "Error when parsing cabal file. Stan will continue without information from .cabal file"+ pure $ Map.fromList $+ map (toSnd (const $ Left $ CabalError err) . hie_hs_file) hies++{- | Recursively find all @.cabal@ files in the current directory and its+subdirectories. It returns maximum 1 @.cabal@ file from each directory.+-}+findCabalFiles :: IO [FilePath]+findCabalFiles = do+ dir <- getCurrentDirectory+ curDirCabal <- findCabalFileDir dir+ dirs <- getSubdirsRecursive dir+ subDirsCabals <- mapM findCabalFileDir dirs+ pure $ catMaybes $ curDirCabal : subDirsCabals++-- | Find a @.cabal@ file in the given directory.+-- TODO: better error handling in stan.+findCabalFileDir :: FilePath -> IO (Maybe FilePath)+findCabalFileDir dir = do+ dirContent <- listDirectory dir+ let cabalFiles = filter isCabal dirContent+ pure $ case cabalFiles of+ [] -> Nothing -- throwError $ NoCabalFile dirPath+ [cabalFile] -> Just $ dir </> cabalFile+ x:_xs -> Just x -- throwError $ MultipleCabalFiles (x :| xs)+ where+ isCabal :: FilePath -> Bool+ isCabal p = takeExtension p == ".cabal"++getSubdirsRecursive :: FilePath -> IO [FilePath]+getSubdirsRecursive fp = do+ all' <- filter nonGenDir <$> listDirectory fp+ dirs <- filterM doesDirectoryExist (mkRel <$> all')+ case dirs of+ [] -> pure []+ ds -> do+ -- unsafeInterleaveIO is required here for performance reasons+ next <- unsafeInterleaveIO $ foldMapA getSubdirsRecursive ds+ pure $ dirs ++ next+ where+ nonGenDir :: FilePath -> Bool+ nonGenDir d =+ d /= "dist"+ && d /= "dist-newstyle"+ && d /= ".stack-work"++ mkRel :: FilePath -> FilePath+ mkRel = (fp </>)++mergeParsedExtensions+ :: Either ExtensionsError ParsedExtensions+ -> Either ExtensionsError ParsedExtensions+ -> ExtensionsResult+mergeParsedExtensions (Left err) _ = Left err+mergeParsedExtensions _ (Left err) = Left err+mergeParsedExtensions (Right exts1) (Right exts2) = mergeAnyExtensions exts1 exts2
+ src/Stan/Category.hs view
@@ -0,0 +1,79 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++__Category__ — a type of 'Stan.Inspection.Inspection'.+-}++module Stan.Category+ ( -- * Data type+ Category (..)++ -- * Pretty printing+ , prettyShowCategory++ -- * Stan categories+ , stanCategories+ , antiPattern+ , infinite+ , list+ , partial+ , spaceLeak+ , syntax+ , unsafe+ ) where++import Colourista (formatWith, magentaBg)+++-- | A type of the inspection.+newtype Category = Category+ { unCategory :: Text+ } deriving newtype (Show, Eq, Hashable)++-- | Show 'Category' in a human-friendly format.+prettyShowCategory :: Category -> Text+prettyShowCategory cat = formatWith [magentaBg] $ "#" <> unCategory cat++-- | @List@ category of Stan inspections.+list :: Category+list = Category "List"++-- | @Partial@ category of Stan inspections.+partial :: Category+partial = Category "Partial"++-- | @Infinite@ category of Stan inspections.+infinite :: Category+infinite = Category "Infinite"++-- | @AntiPattern@ category of Stan inspections.+antiPattern :: Category+antiPattern = Category "AntiPattern"++-- | @SpaceLeak@ category of Stan inspections.+spaceLeak :: Category+spaceLeak = Category "SpaceLeak"++{- | @Syntax@ category of Stan inspections. Usually used in+'Stan.Severity.Style' inspections.+-}+syntax :: Category+syntax = Category "Syntax"++-- | @Unsafe@ category of Stan inspections.+unsafe :: Category+unsafe = Category "Unsafe"++-- | The list of all available Stan 'Category's.+stanCategories :: [Category]+stanCategories =+ [ antiPattern+ , infinite+ , list+ , partial+ , spaceLeak+ , syntax+ , unsafe+ ]
+ src/Stan/Cli.hs view
@@ -0,0 +1,343 @@+{-# LANGUAGE ApplicativeDo #-}++{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++CLI commands and options for @stan@.+-}++module Stan.Cli+ ( StanCommand (..)+ , StanArgs (..)+ , InspectionArgs (..)+ , TomlToCliArgs (..)+ , CliToTomlArgs (..)+ , runStanCli+ , stanParserPrefs+ , stanCliParser+ ) where++import Colourista (blue, bold, formatWith, reset, yellow)+import Colourista.Short (b)+import Data.Char (toUpper)+import Options.Applicative (CommandFields, Mod, Parser, ParserInfo (..), ParserPrefs, auto, columns,+ command, commandGroup, customExecParser, flag, flag', fullDesc, help,+ helpLongEquals, helper, hidden, hsubparser, info, infoOption, internal,+ long, metavar, multiSuffix, option, prefs, progDesc, short,+ showDefaultWith, showHelpOnEmpty, showHelpOnError, strArgument,+ strOption, subparserInline, value)+import Options.Applicative.Help.Chunk (stringChunk)+import Trial (TaggedTrial, fiascoOnEmpty)+import Trial.OptparseApplicative (taggedTrialParser)++import Stan.Category (Category (..))+import Stan.Config (Check (..), CheckFilter (..), CheckType (..), ConfigP (..), PartialConfig,+ Scope (..))+import Stan.Core.Id (Id (..))+import Stan.Info (prettyStanVersion, stanVersion)+import Stan.Inspection (Inspection)+import Stan.Observation (Observation)+import Stan.Report.Settings (ReportSettings (..), ToggleSolution (..), Verbosity (..))+++-- | Commands used in Stan CLI.+data StanCommand+ = Stan !StanArgs -- ^ Just @stan@ with its options.+ | StanInspection !InspectionArgs -- ^ @stan inspection@.+ | StanTomlToCli !TomlToCliArgs -- ^ @stan toml-to-cli@+ | StanCliToToml !CliToTomlArgs -- ^ @stan cli-to-toml@+ | StanInspectionsToMd -- ^ @stan inspections-to-md@++-- | Options used for the main @stan@ command.+data StanArgs = StanArgs+ { stanArgsHiedir :: !FilePath -- ^ Directory with HIE files+ , stanArgsCabalFilePath :: ![FilePath] -- ^ Path to @.cabal@ files.+ , stanArgsReportSettings :: !ReportSettings -- ^ Settings for report+ , stanArgsReport :: !Bool -- ^ Create @HTML@ report?+ , stanArgsUseDefaultConfigFile :: !(TaggedTrial Text Bool) -- ^ Use default @.stan.toml@ file+ , stanArgsConfigFile :: !(Maybe FilePath) -- ^ Path to a custom configurations file.+ , stanArgsConfig :: !PartialConfig+ }++-- | Options used for the @stan inspection@ command.+newtype InspectionArgs = InspectionArgs+ { inspectionArgsId :: Maybe (Id Inspection)+ }++-- | Options used for the @stan toml-to-cli@ command.+newtype TomlToCliArgs = TomlToCliArgs+ { tomlToCliArgsFilePath :: Maybe FilePath+ }++-- | Options used for the @stan cli-to-toml@ command.+data CliToTomlArgs = CliToTomlArgs+ { cliToTomlArgsFilePath :: !(Maybe FilePath)+ , cliToTomlArgsConfig :: !PartialConfig+ }++-- | Run main parser of the @stan@ command line tool.+runStanCli :: IO StanCommand+runStanCli = customExecParser stanParserPrefs stanCliParser++-- | To turn on some special options.+stanParserPrefs :: ParserPrefs+stanParserPrefs = prefs $ mconcat+ [ helpLongEquals+ , showHelpOnEmpty+ , showHelpOnError+ , subparserInline+ , multiSuffix "s"+ , columns 100+ ]++stanCliParser :: ParserInfo StanCommand+stanCliParser = modifyHeader $ info (helper <*> versionP <*> stan) fullDesc++{- | Stan tool parser. It either uses the named commands or the main @stan@+command.+-}+stan :: Parser StanCommand+stan = stanInspectionP+ <|> stanTomlToCliP+ <|> stanCliToTomlP+ <|> stanInspectionsToMd+ <|> stanP++-- | @stan@ command parser.+stanP :: Parser StanCommand+stanP = do+ stanArgsConfig <- configP+ stanArgsReport <- reportP+ stanArgsHiedir <- hiedirP+ stanArgsCabalFilePath <- cabalFilePathP+ stanArgsConfigFile <- configFileP+ stanArgsUseDefaultConfigFile <- useDefaultConfigFileP+ stanArgsReportSettings <- reportSettingsP+ pure $ Stan StanArgs{..}++-- | @stan inspection@ command parser.+stanInspectionP :: Parser StanCommand+stanInspectionP = hsubparser $+ command "inspection" (info inspectionP (progDesc "Show all Inspections"))+ <> commandVar "INSPECTION"+ <> help "Command to show all or specific inspection"+ where+ inspectionP :: Parser StanCommand+ inspectionP = do+ inspectionArgsId <- Id <<$>> optional ( strArgument+ (metavar "INSPECTION_ID" <> help "Show specific Inspection information"))+ pure $ StanInspection InspectionArgs{..}++stanTomlToCliP :: Parser StanCommand+stanTomlToCliP = hsubparser $ commandGroup "TOML Configurations"+ <> command "toml-to-cli"+ ( info tomlToCliP+ (progDesc "Convert TOML configuration file into stan CLI command")+ )+ <> commandVar "TOML-TO-CLI"+ <> help "Command to convert TOML configurations to CLI"+ where+ tomlToCliP :: Parser StanCommand+ tomlToCliP = do+ tomlToCliArgsFilePath <- configFileP+ pure $ StanTomlToCli TomlToCliArgs{..}++stanCliToTomlP :: Parser StanCommand+stanCliToTomlP = hsubparser $ commandGroup "TOML Configurations"+ <> command "cli-to-toml"+ ( info cliToTomlP+ (progDesc "Convert CLI arguments into stan TOML configuration")+ )+ <> commandVar "CLI-TO-TOML"+ <> help "Command to convert CLI configurations to TOML"+ where+ cliToTomlP :: Parser StanCommand+ cliToTomlP = do+ cliToTomlArgsFilePath <- configFileP+ cliToTomlArgsConfig <- configP+ pure $ StanCliToToml CliToTomlArgs{..}++stanInspectionsToMd :: Parser StanCommand+stanInspectionsToMd = hsubparser+ $ command "inspections-to-md"+ (info (pure StanInspectionsToMd)+ (progDesc "Create md with all inspections info")+ )+ <> help "Create md with all inspections info"+ <> hidden <> internal++hiedirP :: Parser FilePath+hiedirP = strOption $ mconcat+ [ long "hiedir"+ , metavar "DIR_PATH"+ , value ".hie"+ , showDefaultWith (formatWith [blue, bold])+ , help "Relative path to the directory with HIE files"+ ]++cabalFilePathP :: Parser [FilePath]+cabalFilePathP = many $ strOption $ mconcat+ [ long "cabal-file-path"+ , metavar "FILE_PATH"+ , help "Relative path to the .cabal file (can specify many of this option)"+ ]++configFileP :: Parser (Maybe FilePath)+configFileP = optional $ strOption $ mconcat+ [ long "config-file"+ , metavar "FILE_PATH"+ , help "Relative path to the .toml configurations file"+ ]++useDefaultConfigFileP :: Parser (TaggedTrial Text Bool)+useDefaultConfigFileP = taggedTrialParser "no-default" $ flag' False $ mconcat+ [ long "no-default"+ , help "Ignore local .stan.toml configuration file"+ ]++reportP :: Parser Bool+reportP = do+ res <- optional $ hsubparser $+ command "report"+ (info pass (progDesc "Generate HTML Report"))+ <> commandGroup "Reporting"+ <> commandVar "REPORT"+ <> help "Command to generate an HTML Report"+ pure $ isJust res++reportSettingsP :: Parser ReportSettings+reportSettingsP = do+ reportSettingsVerbosity <- verbosityP+ reportSettingsSolutionVerbosity <- toggleSolutionP+ pure ReportSettings{..}++-- | The solution is shown by default and gets hidden when option is specified.+toggleSolutionP :: Parser ToggleSolution+toggleSolutionP = flag ShowSolution HideSolution $ mconcat+ [ long "hide-solution"+ , help "Hide verbose solution information for observations"+ ]++-- | The 'Observation' is shown juicy by default and gets shortened when option is specified.+verbosityP :: Parser Verbosity+verbosityP = flag Verbose NonVerbose $ mconcat+ [ long "short"+ , short 's'+ , help "Hide verbose output information for observations"+ ]++data ConfigCommand+ = CheckCommand !Check+ | RemoveCommand !Scope+ | IgnoreCommand !(Id Observation)++partitionCommands :: [ConfigCommand] -> ([Check], [Scope], [Id Observation])+partitionCommands [] = ([], [], [])+partitionCommands (cmd : rest) =+ let (check, remove, obs) = partitionCommands rest+ in case cmd of+ CheckCommand ch -> (ch:check, remove, obs)+ RemoveCommand r -> (check, r:remove, obs)+ IgnoreCommand o -> (check, remove, o:obs)++configP :: Parser PartialConfig+configP = do+ res <- many $+ cmd "check" "Specify list of checks" CheckCommand checkP+ <|> cmd "remove" "Specify scope to be removed" RemoveCommand scopeP+ <|> cmd "ignore" "Specify list of what needs to be ignored" IgnoreCommand (idP "Observations")+ pure $+ let (checks, removed, ignored) = partitionCommands res+ in ConfigP+ { configChecks = fiascoOnEmpty "CLI" "checks" checks+ , configRemoved = fiascoOnEmpty "CLI" "remove" removed+ , configIgnored = fiascoOnEmpty "CLI" "ignore" ignored+ }+ where+ cmd :: String -> String -> (a -> ConfigCommand) -> Parser a -> Parser ConfigCommand+ cmd name h cc p = hsubparser+ ( command name+ (info (cc <$> p) (progDesc h))+ <> commandVar (map toUpper name)+ <> help ("Command to " <> h)+ <> commandGroup "CLI Configurations"+ )++-- | Parser of an 'Id'. Receives a string to specify in Help what kind of ID is this.+idP :: String -> Parser (Id a)+idP name = Id <$> strOption+ (long "id"+ <> metavar (map toUpper name <> "_ID")+ <> help (name <> " ID to be used"))++checkP :: Parser Check+checkP = do+ checkType <- checkTypeP+ checkFilter <- checkFilterP+ checkScope <- scopeP+ pure Check{..}++checkTypeP :: Parser CheckType+checkTypeP =+ -- QUESTION: is it better than --type=Exclude or --type=Include+ flag' Include (long "include" <> help "Include check")+ <|> flag' Exclude (long "exclude" <> help "Exclude check")++checkFilterP :: Parser CheckFilter+checkFilterP =+ CheckInspection <$> idP "Inspection"+ <|> CheckSeverity <$> option auto+ -- TODO: how to specify all possible values here in help?+ (long "severity"+ <> metavar "SEVERITY"+ <> help "Inspection Severity to exclude or include")+ <|> CheckCategory . Category <$> strOption+ (long "category"+ <> metavar "CATEGORY"+ <> help "Inspection Category to exclude or include")+ <|> flag' CheckAll+ (long "filter-all"+ <> help "Exclude or include ALL inspections")++scopeP :: Parser Scope+scopeP =+ ScopeFile <$> strOption+ (long "file"+ <> metavar "FILE_PATH"+ <> help "File to exclude or include")+ <|> ScopeDirectory <$> strOption+ (long "directory"+ <> metavar "DIRECTORY_PATH"+ <> help "Directory to exclude or include")+ <|> flag' ScopeAll+ (long "scope-all"+ <> help "Apply check to all files")++-- | Show the version of the tool.+versionP :: Parser (a -> a)+versionP = infoOption (prettyStanVersion stanVersion)+ $ long "version"+ <> short 'v'+ <> help "Show Stan's version"+ <> hidden++-- to put custom header which doesn't cut all spaces+modifyHeader :: ParserInfo a -> ParserInfo a+modifyHeader p = p { infoHeader = stringChunk $ toString header }++header :: Text+header = unlines+ [ yellow+ , " ______________ _ __"+ , " / ___/_ __/ | / | / /"+ , " \\__ \\ / / / /| | / |/ / "+ , " ___/ // / / ___ |/ /| / "+ , " /____//_/ /_/ |_/_/ |_/ "+ , reset+ , " Haskell " <> b "ST" <> "atic " <> b "AN" <> "alyser"+ ]++commandVar :: String -> Mod CommandFields a+commandVar = metavar . b
+ src/Stan/Config.hs view
@@ -0,0 +1,467 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++@stan@ runtime configuration that allows customizing the set of+inspections to check the code against.+-}++module Stan.Config+ ( -- * Data types+ ConfigP (..)+ , Config+ , PartialConfig+ , Check (..)+ , CheckType (..)+ , CheckFilter (..)+ , Scope (..)++ -- * Default+ , defaultConfig+ , mkDefaultChecks++ -- * Final stage+ , finaliseConfig++ -- * Printing+ , configToCliCommand++ -- * Apply config+ -- $applyConfig+ , applyConfig+ , applyChecks+ , applyChecksFor+ ) where++import Trial ((::-), Phase (..), Trial, withTag)++import Stan.Category (Category (..))+import Stan.Core.Id (Id (..))+import Stan.Inspection (Inspection (..))+import Stan.Inspection.All (inspections, inspectionsIds, lookupInspectionById)+import Stan.Observation (Observation (..))+import Stan.Severity (Severity (..))++import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet+import qualified Data.Text as T+++{- | Main configuration type for the following purposes:++* Filtering inspections (including or ignoring) per scope (file,+ directory, all)+-}+data ConfigP (p :: Phase Text) = ConfigP+ { configChecks :: !(p ::- [Check])+ , configRemoved :: !(p ::- [Scope])+ , configIgnored :: !(p ::- [Id Observation])+ -- , configGroupBy :: !GroupBy+ }++deriving stock instance+ ( Show (p ::- [Check])+ , Show (p ::- [Scope])+ , Show (p ::- [Id Observation])+ ) => Show (ConfigP p)++deriving stock instance+ ( Eq (p ::- [Check])+ , Eq (p ::- [Scope])+ , Eq (p ::- [Id Observation])+ ) => Eq (ConfigP p)++type Config = ConfigP 'Final+type PartialConfig = ConfigP 'Partial++instance Semigroup PartialConfig where+ (<>) :: PartialConfig -> PartialConfig -> PartialConfig+ x <> y = ConfigP+ { configChecks = configChecks x <> configChecks y+ , configRemoved = configRemoved x <> configRemoved y+ , configIgnored = configIgnored x <> configIgnored y+ }++-- | Type of 'Check': 'Include' or 'Exclude' 'Inspection's.+data CheckType+ = Include+ | Exclude+ deriving stock (Show, Eq, Enum, Bounded)++-- | Rule to control the set of inspections per scope.+data Check = Check+ { checkType :: !CheckType+ , checkFilter :: !CheckFilter+ , checkScope :: !Scope+ } deriving stock (Show, Eq)++-- | Criterion for inspections filtering.+data CheckFilter+ = CheckInspection !(Id Inspection)+ | CheckSeverity !Severity+ | CheckCategory !Category+ | CheckAll+ deriving stock (Show, Eq)++-- | Where to apply the rule for controlling inspection set.+data Scope+ = ScopeFile !FilePath+ | ScopeDirectory !FilePath+ | ScopeAll+ deriving stock (Show, Eq)++defaultConfig :: PartialConfig+defaultConfig = ConfigP+ { configChecks = withTag "Default" $ pure []+ , configRemoved = withTag "Default" $ pure []+ , configIgnored = withTag "Default" $ pure []+ }++finaliseConfig :: PartialConfig -> Trial Text Config+finaliseConfig config = do+ configChecks <- #configChecks config+ configRemoved <- #configRemoved config+ configIgnored <- #configIgnored config+ pure ConfigP {..}+++{- | Convert TOML configuration to the equivalent CLI command that can+be copy-pasted to get the same results as using the TOML config.++@+ ⓘ Reading Configurations from \/home\/vrom911\/Kowainik\/stan\/.stan.toml ...+stan check --exclude --directory=test/ \\+ check --include \\+ check --exclude --inspectionId=STAN-0002 \\+ check --exclude --inspectionId=STAN-0001 --file=src/MyFile.hs+ remove --file=src/Secret.hs+ ignore --id="STAN0001-asdfgh42:42"+@+-}+configToCliCommand :: Config -> Text+configToCliCommand ConfigP{..} = "stan " <> T.intercalate " \\\n "+ ( map checkToCli configChecks+ <> map removedToCli configRemoved+ <> map ignoredToCli configIgnored+ )+ where+ checkToCli :: Check -> Text+ checkToCli Check{..} = "check"+ <> checkTypeToCli checkType+ <> checkFilterToCli checkFilter+ <> scopeToCli checkScope++ removedToCli :: Scope -> Text+ removedToCli scope = "remove"+ <> scopeToCli scope++ ignoredToCli :: Id Observation -> Text+ ignoredToCli obsId = "ignore"+ <> idToCli obsId++ idToCli :: Id a -> Text+ idToCli = (<>) " --id=" . unId++ checkTypeToCli :: CheckType -> Text+ checkTypeToCli = \case+ Include -> " --include"+ Exclude -> " --exclude"++ checkFilterToCli :: CheckFilter -> Text+ checkFilterToCli = \case+ CheckInspection insId -> idToCli insId+ CheckSeverity sev -> " --severity=" <> show sev+ CheckCategory cat -> " --category=" <> unCategory cat+ CheckAll -> " --filter-all"++ scopeToCli :: Scope -> Text+ scopeToCli = \case+ ScopeFile file -> " --file=" <> toText file+ ScopeDirectory dir -> " --directory=" <> toText dir+ ScopeAll -> " --scope-all"++mkDefaultChecks :: [FilePath] -> HashMap FilePath (HashSet (Id Inspection))+mkDefaultChecks = HashMap.fromList . map (, inspectionsIds)++{- | Apply configuration to the given list of files to get the set of+inspections for each file.++The algorithm:++1. Remove all files specified by the @remove@ option.+2. Run 'applyChecks' on the remaining files.+-}+applyConfig+ :: [FilePath]+ -- ^ Paths to project files+ -> Config+ -- ^ Stan runtime configuration+ -> HashMap FilePath (HashSet (Id Inspection))+ -- ^ Resulting set of inspections for each file+applyConfig paths ConfigP{..} =+ applyChecks (filter notRemoved paths) configChecks+ where+ -- TODO: can be implemented efficiently, but the more efficient+ -- implementation is required only if the @configRemoved@ can have+ -- >= 1K entries+ notRemoved :: FilePath -> Bool+ notRemoved path = all (isNotInScope path) configRemoved++ isNotInScope :: FilePath -> Scope -> Bool+ isNotInScope path = \case+ ScopeFile file -> path /= file+ ScopeDirectory dir -> not $ isInDir dir path+ ScopeAll -> False++{- | Convert the list of 'Check's from 'Config' to data structure that+allows filtering of 'Inspection's for given files.+-}+applyChecks+ :: [FilePath]+ -- ^ Paths to project files+ -> [Check]+ -- ^ List of rules+ -> HashMap FilePath (HashSet (Id Inspection))+ -- ^ Resulting set of inspections for each file+applyChecks = applyChecksFor . mkDefaultChecks++{- | Modify existing 'Check's for each file using the given list of+'Check's.+-}+applyChecksFor+ :: HashMap FilePath (HashSet (Id Inspection))+ -- ^ Initial set of inspections for each file+ -> [Check]+ -- ^ List of rules+ -> HashMap FilePath (HashSet (Id Inspection))+ -- ^ Resulting set of inspections for each file+applyChecksFor = foldl' useCheck+ where+ useCheck+ :: HashMap FilePath (HashSet (Id Inspection))+ -> Check+ -> HashMap FilePath (HashSet (Id Inspection))+ useCheck dict Check{..} =+ applyForScope (applyFilter checkType checkFilter) checkScope dict++ applyFilter+ :: CheckType+ -> CheckFilter+ -> HashSet (Id Inspection)+ -> HashSet (Id Inspection)+ applyFilter = \case+ Include -> includeFilter+ Exclude -> excludeFilter++ excludeFilter :: CheckFilter -> HashSet (Id Inspection) -> HashSet (Id Inspection)+ excludeFilter cFilter = HashSet.filter (not . satisfiesFilter cFilter)++ includeFilter :: CheckFilter -> HashSet (Id Inspection) -> HashSet (Id Inspection)+ includeFilter cFilter ins = case cFilter of+ CheckInspection iId -> HashSet.insert iId ins+ CheckSeverity sev ->+ let sevInspections = filter ((== sev) . inspectionSeverity) inspections+ in HashSet.fromList (map inspectionId sevInspections) <> ins+ CheckCategory cat ->+ let catInspections = filter (elem cat . inspectionCategory) inspections+ in HashSet.fromList (map inspectionId catInspections) <> ins+ CheckAll -> inspectionsIds <> ins++ -- Returns 'True' if the given inspection satisfies 'CheckFilter'+ satisfiesFilter :: CheckFilter -> Id Inspection -> Bool+ satisfiesFilter cFilter iId = case lookupInspectionById iId of+ -- TODO: rewrite more efficiently after using GHC-8.10+ Nothing -> False -- no such ID => doesn't satisfy+ Just Inspection{..} -> case cFilter of+ CheckInspection checkId -> iId == checkId+ CheckSeverity sev -> sev == inspectionSeverity+ CheckCategory cat -> cat `elem` inspectionCategory+ CheckAll -> True++ applyForScope+ :: (HashSet (Id Inspection) -> HashSet (Id Inspection))+ -> Scope+ -> HashMap FilePath (HashSet (Id Inspection))+ -> HashMap FilePath (HashSet (Id Inspection))+ applyForScope f cScope hm = case cScope of+ ScopeFile path -> HashMap.adjust f path hm+ ScopeDirectory dir -> HashMap.mapWithKey+ (\path -> if isInDir dir path then f else id)+ hm+ ScopeAll -> f <$> hm++isInDir :: FilePath -> FilePath -> Bool+isInDir dir path = dir `isPrefixOf` path++{- $applyConfig++The 'applyConfig' function transforms the list of rules defined in the+'Config' (either via TOML or CLI) to get the list of 'Inspection's for+each module.++By default, @stan@ runs all 'Inspection's for all modules in the+Haskell project and outputs all 'Observation's it finds. Using+'Config', you can adjust the default setting using your preferences.++=== Algorithm++The algorithm for figuring out the resulting set of 'Inspection's per+module applies each 'Check' one-by-one in order of their appearance.++When introducing a new 'Check' in the config, you must always specify+three key-value pairs:++1. 'CheckType' — control inclusion and exclusion criteria++ * 'Include'++ @+ type = \"Include\"+ @++ * 'Exclude'++ @+ type = \"Exclude\"+ @++2. 'CheckFilter' — how to filter inspections++ * 'CheckInspection': by specific 'Inspection' 'Id'++ @+ id = "STAN-0001"+ @++ * 'CheckSeverity': by specific 'Severity'++ @+ severity = \"Warning\"+ @++ * 'CheckCategory': by specific 'Category'++ @+ category = \"Partial\"+ @++ * 'CheckAll': applied to all 'Inspection's++ @+ filter = "all"+ @++3. 'Scope' — where to apply check++ * 'ScopeFile': only to the specific file++ @+ file = "src\/MyModule.hs"+ @++ * 'ScopeDirectory': to all files in the specified directory++ @+ directory = "text\/"+ @++ * 'ScopeAll': to all files++ @+ scope = "all"+ @++The algorithm doesn't remove any files or inspections from the+consideration completely. So, for example, if you exclude all+inspections in a specific file, new inspections can be added for this+file later by the follow up rules.++However, if you want to completely remove some files or directory from+analysis, you can use the @remove@ key:++@+[[remove]]+file = "src\/Autogenerated.hs"+@++=== Common examples++This section contains examples of custom configuration (in TOML) for+common cases.++1. Exclude all 'Inspection's.++ @+ [[check]]+ type = \"Exclude\"+ filter = "all"+ scope = "all"+ @++2. Exclude all 'Inspection's only for specific file.++ @+ [[check]]+ type = \"Exclude\"+ filter = "all"+ file = "src/MyModule.hs"+ @++3. Exclude a specific 'Inspection' in all files:++ @+ [[check]]+ type = \"Exclude\"+ id = "STAN-0001"+ scope = "all"+ @++4. Exclude all 'Inspection's for specific file except 'Inspection's+that have a category @Partial@.++ @+ # exclude all inspections for a file+ [[check]]+ type = \"Exclude\"+ filter = "all"+ file = "src/MyModule.hs"++ # return back only required inspections+ [[check]]+ type = \"Include\"+ category = \"Partial\"+ file = "src/MyModule.hs"+ @++5. Keep 'Inspection's only with the category @Partial@ for all files+except a single one.++ @+ # exclude all inspections+ [[check]]+ type = \"Exclude\"+ filter = "all"+ scope = "all"++ # return back inspections with the category Partial+ [[check]]+ type = \"Include\"+ category = \"Partial\"+ scope = "all"++ # finally, disable all inspections for a specific file+ [[check]]+ type = \"Exclude\"+ filter = "all"+ file = "src/MyModule.hs"+ @+-}
+ src/Stan/Config/Pretty.hs view
@@ -0,0 +1,92 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++@stan@ configuration pretty printing helper functions.+-}++module Stan.Config.Pretty+ ( ConfigAction (..)+ , prettyConfigAction+ , configActionClass+ , configActionColour+ , prettyConfigCli++ , configToTriples+ ) where++import Colourista (bold, formatWith, green, magenta, red, yellow)++import Stan.Category (Category (..))+import Stan.Config (Check (..), CheckFilter (..), CheckType (..), Config, ConfigP (..), Scope (..))+import Stan.Core.Id (Id (..))+++data ConfigAction+ = RemoveAction+ | IncludeAction+ | ExcludeAction+ | IgnoreAction+ deriving stock (Show, Eq)++prettyConfigAction :: ConfigAction -> Text+prettyConfigAction = \case+ RemoveAction -> "— Remove "+ IncludeAction -> "∪ Include"+ ExcludeAction -> "∩ Exclude"+ IgnoreAction -> "✖ Ignore "++configActionClass :: ConfigAction -> Text+configActionClass = \case+ RemoveAction -> "remove"+ IncludeAction -> "include"+ ExcludeAction -> "exclude"+ IgnoreAction -> "ignore"++configActionColour :: ConfigAction -> Text+configActionColour = \case+ RemoveAction -> red+ IncludeAction -> green+ ExcludeAction -> yellow+ IgnoreAction -> magenta++configToTriples :: Config -> [(ConfigAction, Text, Text)]+configToTriples ConfigP{..} =+ map ((RemoveAction, "", ) . prettyScope) configRemoved+ ++ map checkToTriple configChecks+ ++ map ((IgnoreAction, , "") . unId) configIgnored++checkToTriple :: Check -> (ConfigAction, Text, Text)+checkToTriple Check{..} =+ ( checkTypeToAction checkType+ , prettyFilter checkFilter+ , prettyScope checkScope+ )++checkTypeToAction :: CheckType -> ConfigAction+checkTypeToAction = \case+ Include -> IncludeAction+ Exclude -> ExcludeAction++prettyFilter :: CheckFilter -> Text+prettyFilter = \case+ CheckInspection ins -> "ID: " <> unId ins+ CheckSeverity sev -> "Severity: " <> show sev+ CheckCategory cat -> "Category: " <> unCategory cat+ CheckAll -> "All inspections"++prettyScope :: Scope -> Text+prettyScope = \case+ ScopeFile fp -> "File: " <> toText fp+ ScopeDirectory dir -> "Directory: " <> toText dir+ ScopeAll -> "All files"++prettyConfigCli :: Config -> Text+prettyConfigCli = unlines . concatMap action . configToTriples+ where+ action :: (ConfigAction, Text, Text) -> [Text]+ action (act, check, scope) =+ formatWith [configActionColour act, bold] (prettyConfigAction act)+ : [ " " <> check | check /= ""]+ ++ [ " " <> scope | scope /= ""]
+ src/Stan/Core/Id.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Safe 'Id' representation.+-}++module Stan.Core.Id+ ( Id (..)+ , AnyId+ , castId+ ) where++import Data.Type.Equality (type (==))+++{- | A wrapper around the textual value to safely represent IDs for different+structures by using a phantom parameter.+-}+newtype Id a = Id+ { unId :: Text+ } deriving stock (Show)+ deriving newtype (Eq, Ord, Hashable)++{- | A type alias for the situations when we don't care about the parameter of+'Id' but don't want to deal with type variables.+-}+type AnyId = Id ()++{- | Unsafe cast of 'Id'. Implementation uses smart trick to enforce usage+always with @TypeApplications@.+-}+castId+ :: forall to from to'+ . ((to == to') ~ 'True)+ => Id from+ -> Id to'+castId (Id a) = Id a
+ src/Stan/Core/List.hs view
@@ -0,0 +1,46 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Extra functions to work with lists.+-}++module Stan.Core.List+ ( checkWith+ , nonRepeatingPairs+ ) where++{- | Checks that two lists have the same length and that a given+binary predicate returns 'True' on each corresponding pair of+elements.++>>> checkWith (==) [] []+True+>>> checkWith (==) [1, 2] [1, 2]+True+>>> checkWith (==) [1, 2] [2, 1]+False+>>> checkWith (==) [1, 2] [1]+False+-}+checkWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool+checkWith _ [] [] = True+checkWith _ [] _ = False+checkWith _ _ [] = False+checkWith f (a:as) (b:bs) = f a b && checkWith f as bs++{- | Returns list all element pairs without the following properties:++* No element with itself: @(x, x)@+* Only one of @(x, y)@ and @(y, x)@ will be in the result++In other words, it's like taking the cross product of the list with+itself and then keeping only the half of that without the diagonal.++>>> foo [1..3]+[(1, 2), (1, 3), (2, 3)]+-}+nonRepeatingPairs :: [a] -> [(a, a)]+nonRepeatingPairs [] = []+nonRepeatingPairs (x:xs) = map (x,) xs ++ nonRepeatingPairs xs
+ src/Stan/Core/ModuleName.hs view
@@ -0,0 +1,31 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Wrapper around Haskell module names and conversion functions for GHC+types.+-}++module Stan.Core.ModuleName+ ( ModuleName (..)+ , fromGhcModule+ , fromGhcModuleName+ ) where++import qualified Stan.Ghc.Compat as Ghc+++-- | Wrapper around Haskell module name.+newtype ModuleName = ModuleName+ { unModuleName :: Text+ } deriving stock (Show)+ deriving newtype (Eq, Hashable, IsString)++-- | Convert 'GHC.ModuleName' to 'ModuleName'.+fromGhcModuleName :: Ghc.ModuleName -> ModuleName+fromGhcModuleName = ModuleName . toText . Ghc.moduleNameString++-- | Extract 'ModuleName' from 'GHC.Module'.+fromGhcModule :: Ghc.Module -> ModuleName+fromGhcModule = fromGhcModuleName . Ghc.moduleName
+ src/Stan/EnvVars.hs view
@@ -0,0 +1,41 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Environment variables for @stan@.+-}++module Stan.EnvVars+ ( EnvVars (..)+ , getEnvVars++ , envVarsToText+ ) where++import System.Environment (lookupEnv)+import Trial (TaggedTrial, Trial (..), fiasco, withTag)+++newtype EnvVars = EnvVars+ { envVarsUseDefaultConfigFile :: TaggedTrial Text Bool+ }++getEnvVars :: IO EnvVars+getEnvVars = do+ envVarsUseDefaultConfigFile <- getEnvVar "STAN_USE_DEFAULT_CONFIG" $ \case+ "True" -> pure True+ "False" -> pure False+ _ -> fiasco "Incorrect value is set for STAN_USE_DEFAULT_CONFIG"+ pure EnvVars{..}+ where+ getEnvVar :: String -> (String -> Trial Text a) -> IO (TaggedTrial Text a)+ getEnvVar var act = lookupEnv var <&> \val -> withTag "EnvVar" $ case val of+ Nothing -> fiasco $ "No " <> toText var <> " Env Variable is set"++ Just s -> act s++envVarsToText :: EnvVars -> Text+envVarsToText EnvVars{..} = case envVarsUseDefaultConfigFile of+ Result _ (_, res) -> "STAN_USE_DEFAULT_CONFIG=" <> show res+ Fiasco _ -> ""
+ src/Stan/Example.hs view
@@ -0,0 +1,63 @@+{- HLINT ignore "Unused LANGUAGE pragma" -}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}++{-# LANGUAGE NoUndecidableInstances #-}+{-# LANGUAGE PatternSynonyms #-}++{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Module that contains code that should trigger various beautiful Stan inspections :)+-}++module Stan.Example () where++import System.FilePath ((</>))++import qualified Data.ByteString.Char8 as BS8+import qualified Data.List as P+import qualified Text.Read as P+++mkMyUrlPart :: String -> String+mkMyUrlPart myUrl = myUrl </> "asd"++pairLength :: Int+pairLength = length ((1, 2) :: (Int, Int))++listIndxs :: [a] -> [Int]+listIndxs xs = [0 .. length xs]++toByteString :: String -> BS8.ByteString+toByteString = BS8.pack++pathToX :: FilePath -> FilePath+pathToX x = "src/lib" </> x++getFirstIPromise :: [a] -> a+getFirstIPromise = P.head++parseInt :: String -> Int+parseInt = P.read++quad :: Int -> (Int, Int, Int, Int)+quad x = (x, x, x, x)++(?+?) :: Int -> Int -> Int+(?+?) = (+)++isEq :: Int -> Int -> Bool+isEq x y+ | x < y = False+ | x > y = False+ | otherwise = True++prettyOrdering :: Ordering -> String+prettyOrdering = \case {GT -> "GT"; _ -> "LT"}++data User = User+ { userName :: !String+ , userAge :: Int+ }
+ src/Stan/FileInfo.hs view
@@ -0,0 +1,57 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++File (or module) specific information.+-}++module Stan.FileInfo+ ( FileMap+ , FileInfo (..)++ , extensionsToText+ , isExtensionDisabled+ ) where++import Extensions (Extensions (..), ExtensionsError, ExtensionsResult, OnOffExtension (..),+ ParsedExtensions (..), showOnOffExtension)+import GHC.LanguageExtensions.Type (Extension)++import Stan.Core.ModuleName (ModuleName)+import Stan.Observation (Observations)++import qualified Data.Set as Set+++-- | File specific information.+data FileInfo = FileInfo+ { fileInfoPath :: !FilePath+ , fileInfoModuleName :: !ModuleName+ , fileInfoLoc :: !Int+ , fileInfoCabalExtensions :: !(Either ExtensionsError ParsedExtensions)+ , fileInfoExtensions :: !(Either ExtensionsError ParsedExtensions)+ , fileInfoMergedExtensions :: !ExtensionsResult+ , fileInfoObservations :: !Observations+ } deriving stock (Show, Eq)++type FileMap = Map FilePath FileInfo++-- | Return the list of pretty-printed extensions.+extensionsToText :: Either ExtensionsError ParsedExtensions -> [Text]+extensionsToText = \case+ Left _ -> ["Unable to extract extensions"]+ Right ParsedExtensions{..} ->+ let exts = map showOnOffExtension parsedExtensionsAll in+ case parsedExtensionsSafe of+ Just s -> show s : exts+ Nothing -> exts++{- | Check whether the given extension is disabled+-}+isExtensionDisabled :: Extension -> ExtensionsResult -> Bool+isExtensionDisabled ext = \case+ Left _ -> True -- no info about extensions, consider it disabled+ Right Extensions{..} ->+ Set.notMember (On ext) extensionsAll+ || Set.member (Off ext) extensionsAll
+ src/Stan/Ghc/Compat.hs view
@@ -0,0 +1,59 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Compatibility module for GHC types and functions. Reexports all+required API to work with the GHC API.+-}++module Stan.Ghc.Compat+ ( -- * Modules+ Module+ , ModuleName+ , moduleNameString+ , moduleName+ , moduleStableString+ , moduleUnitId++ -- * Names+ , Name+ , isExternalName+ , isSymOcc+ , nameModule+ , nameOccName+ , nameStableString+ , occNameString++ -- * Source locations+ , RealSrcSpan+ , srcSpanEndCol+ , srcSpanStartCol+ , srcSpanStartLine+ , srcSpanEndLine+ , srcSpanFile++ -- * Other common types (for debugging and not only)+ , ArgFlag (..)+ , AvailInfo (..)+ , FastString+ , FieldLbl (..)+ , IfaceTyCon (..)+ , IfaceTyConInfo (..)+ , IfaceTyConSort (..)+ , IfaceTyLit (..)+ , PromotionFlag (..)+ , TupleSort (..)+ ) where++import Avail (AvailInfo (..))+import BasicTypes (PromotionFlag (..), TupleSort (..))+import FastString (FastString)+import FieldLabel (FieldLbl (..))+import IfaceType (IfaceTyCon (..), IfaceTyConInfo (..), IfaceTyConSort (..), IfaceTyLit (..))+import Module (Module, ModuleName, moduleName, moduleNameString, moduleStableString, moduleUnitId)+import Name (Name, isExternalName, nameModule, nameOccName, nameStableString)+import OccName (isSymOcc, occNameString)+import SrcLoc (RealSrcSpan, srcSpanEndCol, srcSpanEndLine, srcSpanFile, srcSpanStartCol,+ srcSpanStartLine)+import Var (ArgFlag (..))
+ src/Stan/Hie.hs view
@@ -0,0 +1,99 @@+{- HLINT ignore "Redundant if" -}++{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Functions to work with @hie@ specific parts.+-}++module Stan.Hie+ ( readHieFiles+ , countLinesOfCode+ , eqAst+ , slice+ ) where++import Colourista (errorMessage, infoMessage, warningMessage)+import System.Directory (doesDirectoryExist, doesFileExist)+import System.Directory.Recursive (getDirRecursive)+import System.FilePath (takeExtension)++import Stan.Core.List (checkWith)+import Stan.Ghc.Compat (RealSrcSpan, srcSpanEndCol, srcSpanStartCol, srcSpanStartLine)+import Stan.Hie.Compat (HieAST (..), HieFile (..), HieFileResult (hie_file_result), NameCache,+ NodeInfo (..), initNameCache, mkSplitUniqSupply, readHieFile)+import Stan.Hie.Debug ()+import Stan.Pattern.Ast (literalAnns)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.Set as Set+import qualified Relude.Unsafe as Unsafe+++{- | Returns contents of all @.hie@ files recursively in the given+@hie@ directory.+-}+readHieFiles :: FilePath -> IO [HieFile]+readHieFiles hieDir = do+ unlessM (doesDirectoryExist hieDir) $ do+ errorMessage $ "Directory with HIE files doesn't exist: " <> toText hieDir+ infoMessage "Use the '--hiedir' CLI option to specify path to the directory with HIE files"+ exitFailure++ nameCache <- createNameCache+ hieContent <- getDirRecursive hieDir+ let isHieFile f = (&&) (takeExtension f == ".hie") <$> doesFileExist f+ hiePaths <- filterM isHieFile hieContent++ when (null hiePaths) $ warningMessage $+ "The directory with HIE files doesn't contain any HIE files: " <> toText hieDir++ forM hiePaths $ \hiePath -> do+ (hieFileResult, _newCache) <- readHieFile nameCache hiePath+ pure $ hie_file_result hieFileResult++createNameCache :: IO NameCache+createNameCache = do+ uniqSupply <- mkSplitUniqSupply 'z'+ pure $ initNameCache uniqSupply []++-- | Get the number of lines of code in the file by analising 'HieFile'.+countLinesOfCode :: HieFile -> Int+countLinesOfCode HieFile{..} = length $ BS8.lines hie_hs_src++{- | Take sub-bytestring according to a given span.++TODO: currently works only with single-line spans+-}+slice :: RealSrcSpan -> ByteString -> ByteString+slice span =+ BS.take (srcSpanEndCol span - srcSpanStartCol span)+ . BS.drop (srcSpanStartCol span - 1)+ . Unsafe.at (srcSpanStartLine span - 1)+ . BS8.lines++{- | Compare two AST nodes on equality. This is a more relaxed version+of the 'Eq' instance for 'HieAST' because it doesn't compare source+locations. This function is useful if you want to check whether two+AST nodes represent the same AST.++This function needs to take the original 'HieFile' because constants+are not stored in 'HieAST' and to compare constants we need to compare+parts of source code.+-}+eqAst :: forall a . Eq a => HieFile -> HieAST a -> HieAST a -> Bool+eqAst HieFile{..} = eqNodes+ where+ eqNodes :: HieAST a -> HieAST a -> Bool+ eqNodes (Node info1 span1 children1) (Node info2 span2 children2) =+ eqInfo info1 info2 && checkWith eqNodes children1 children2+ where+ eqInfo :: NodeInfo a -> NodeInfo a -> Bool+ eqInfo (NodeInfo anns1 types1 ids1) (NodeInfo anns2 types2 ids2) =+ anns1 == anns2 && types1 == types2 && ids1 == ids2 &&+ if Set.member literalAnns anns1+ then slice span1 hie_hs_src == slice span2 hie_hs_src+ else True
+ src/Stan/Hie/Compat.hs view
@@ -0,0 +1,40 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Compatibility module for HIE types from GHC API. Reexports all+required API to work with HIE types.+-}++module Stan.Hie.Compat+ ( -- * Main HIE types+ ContextInfo (..)+ , HieArgs (..)+ , HieAST (..)+ , HieASTs (..)+ , HieFile (..)+ , HieType (..)+ , HieTypeFlat+ , IEType (..)+ , Identifier+ , IdentifierDetails (..)+ , NodeInfo (..)+ , TypeIndex++ -- * Binary interface to hie files+ , HieFileResult (hie_file_result)+ , readHieFile++ -- * Name cache to read HIE files+ , NameCache+ , initNameCache+ , mkSplitUniqSupply+ ) where++import HieBin (HieFileResult (hie_file_result), readHieFile)+import HieTypes (ContextInfo (..), HieAST (..), HieASTs (..), HieArgs (..), HieFile (..),+ HieType (..), HieTypeFlat, IEType (..), Identifier, IdentifierDetails (..),+ NodeInfo (..), TypeIndex)+import NameCache (NameCache, initNameCache)+import UniqSupply (mkSplitUniqSupply)
+ src/Stan/Hie/Debug.hs view
@@ -0,0 +1,80 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE StandaloneDeriving #-}++{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Useful debugging and printing utilities for HIE types. They are+implemented in two ways:++1. Using derived 'Show' instances.+2. Using @ghc@ pretty-printing.++To make full use of derived 'Show' instances, add the @pretty-simple@+package to dependencies and use the @pPrint@ function from the+@Text.Pretty.Simple@ module.+-}++module Stan.Hie.Debug+ ( debugHieFile+ ) where++import Text.Pretty.Simple (pPrint)++import Stan.Core.ModuleName (fromGhcModule)+import Stan.Ghc.Compat (ArgFlag (..), AvailInfo (..), FieldLbl (..), IfaceTyCon (..),+ IfaceTyConInfo (..), IfaceTyConSort (..), IfaceTyLit (..), Module,+ ModuleName, Name, PromotionFlag (..), TupleSort (..), isExternalName,+ moduleNameString, moduleStableString, moduleUnitId, nameModule, nameOccName,+ nameStableString, occNameString)+import Stan.Hie.Compat (HieAST (..), HieASTs (..), HieArgs (..), HieFile (..), HieType (..),+ IdentifierDetails (..), NodeInfo (..))+import Stan.NameMeta (NameMeta (..))++import qualified Text.Show+++debugHieFile :: FilePath -> [HieFile] -> IO ()+debugHieFile path hieFiles = do+ let mHieFile = find (\HieFile{..} -> hie_hs_file == path) hieFiles+ whenJust mHieFile pPrint++-- orphan intances+deriving stock instance Show HieFile+deriving stock instance Show a => Show (HieType a)+deriving stock instance Show a => Show (HieAST a)+deriving newtype instance Show a => Show (HieASTs a)+deriving newtype instance Show a => Show (HieArgs a)+deriving stock instance Show a => Show (NodeInfo a)+deriving stock instance Show a => Show (IdentifierDetails a)+deriving stock instance Show IfaceTyCon+deriving stock instance Show IfaceTyConInfo+deriving stock instance Show IfaceTyConSort+deriving stock instance Show IfaceTyLit+deriving stock instance Show PromotionFlag+deriving stock instance Show TupleSort+deriving stock instance Show ArgFlag+deriving stock instance Show AvailInfo+deriving stock instance Show a => Show (FieldLbl a)++instance Show Module where+ show = moduleStableString++instance Show ModuleName where+ show = moduleNameString++instance Show Name where+ show nm =+ if isExternalName nm+ then show $ toNameMeta nm+ else nameStableString nm+ where+ toNameMeta :: Name -> NameMeta+ toNameMeta name =+ let nameMetaName = toText $ occNameString $ nameOccName name+ nameMetaModuleName = fromGhcModule $ nameModule name+ nameMetaPackage = show @Text $ moduleUnitId $ nameModule name+ in NameMeta{..}
+ src/Stan/Hie/MatchAst.hs view
@@ -0,0 +1,92 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Some 'Stan.Inspection.Inspection's require to know about AST and some+mechanism to match parts of syntax tree to the given+'PatternAst'. This information on AST expressions is taken from @HIE+files@ in a more suitable view.++This module contains an implementation of the process of retrieval of AST+information from @HIE@ files.+-}++module Stan.Hie.MatchAst+ ( hieMatchPatternAst+ ) where++import Data.Char (toLower)++import Stan.Core.List (checkWith)+import Stan.Ghc.Compat (FastString, nameOccName, occNameString)+import Stan.Hie (slice)+import Stan.Hie.Compat (HieAST (..), HieFile (..), Identifier, IdentifierDetails, NodeInfo (..),+ TypeIndex)+import Stan.Hie.MatchType (hieMatchPatternType)+import Stan.NameMeta (NameMeta, hieMatchNameMeta)+import Stan.Pattern.Ast (Literal (..), PatternAst (..), literalAnns)+import Stan.Pattern.Type (PatternType)++import qualified Data.ByteString as BS+import qualified Data.List as Str+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+++{- | Matching function that matches current AST node with a given+pattern.+-}+hieMatchPatternAst+ :: HieFile -- ^ HIE file+ -> HieAST TypeIndex -- ^ Current AST node to match+ -> PatternAst -- ^ Pattern to match against+ -> Bool -- ^ 'True' if pattern matches AST node+hieMatchPatternAst hie@HieFile{..} node@Node{..} = \case+ PatternAstAnything -> True+ PatternAstNeg p ->+ not (hieMatchPatternAst hie node p)+ PatternAstOr p1 p2 ->+ hieMatchPatternAst hie node p1+ || hieMatchPatternAst hie node p2+ PatternAstAnd p1 p2 ->+ hieMatchPatternAst hie node p1+ && hieMatchPatternAst hie node p2+ PatternAstConstant lit ->+ Set.member literalAnns (nodeAnnotations nodeInfo)+ && ( let span = slice nodeSpan hie_hs_src in case lit of+ ExactNum n -> readMaybe (decodeUtf8 span) == Just n+ ExactStr s -> span == s+ PrefixStr s -> s `BS.isPrefixOf` span+ ContainStr s -> s `BS.isInfixOf` span+ AnyLiteral -> True+ )+ PatternAstName nameMeta patType ->+ any (matchNameAndType nameMeta patType)+ $ Map.assocs+ $ nodeIdentifiers nodeInfo+ PatternAstNode tags ->+ matchAnnotations tags nodeInfo+ PatternAstNodeExact tags patChildren ->+ matchAnnotations tags nodeInfo+ && checkWith (hieMatchPatternAst hie) nodeChildren patChildren+ PatternAstVarName varName -> isJust $ find+ (\case+ Right x -> varName `Str.isInfixOf` map toLower (occNameString $ nameOccName x)+ Left _ -> False+ )+ $ Map.keys $ nodeIdentifiers nodeInfo+ where+ matchAnnotations :: Set (FastString, FastString) -> NodeInfo TypeIndex -> Bool+ matchAnnotations tags NodeInfo{..} = tags `Set.isSubsetOf` nodeAnnotations++ matchNameAndType+ :: NameMeta+ -> PatternType+ -> (Identifier, IdentifierDetails TypeIndex)+ -> Bool+ matchNameAndType nameMeta patType ids =+ hieMatchNameMeta nameMeta ids+ && case nodeType nodeInfo of+ [] -> False+ t : _ -> hieMatchPatternType hie_types patType t
+ src/Stan/Hie/MatchType.hs view
@@ -0,0 +1,83 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Some 'Stan.Inspection.Inspection's require to know about types and some+mechanism to match types to the given 'PatternType'. This information on types/type+expressions is taken from @HIE files@ in a more suitable view.++Let's take a look at the function @foo@:++@+foo :: NonEmpty String -> Int+@++In @HIE@ files it will be stored as an 'Array' like this:++@+ 1 -> "Int" []+ 2 -> "String" []+ 3 -> "NonEmpty" [ 2 ]+ 4 -> FunType 3 1+@++This module contains an implementation of the process of retrieval of this+information from there.+-}++module Stan.Hie.MatchType+ ( hieMatchPatternType+ ) where++import Data.Array (Array)++import Stan.Core.List (checkWith)+import Stan.Ghc.Compat (IfaceTyCon (..), IfaceTyConInfo (..), PromotionFlag (NotPromoted))+import Stan.Hie.Compat (HieArgs (..), HieType (..), HieTypeFlat, TypeIndex)+import Stan.NameMeta (compareNames)+import Stan.Pattern.Type (PatternType (..))++import qualified Data.Array as Arr+++{- | Matching function that searches the array of types recursively.+-}+hieMatchPatternType+ :: Array TypeIndex HieTypeFlat -- ^ Array of all types in HIE file+ -> PatternType -- ^ Our search query+ -> TypeIndex -- ^ Index of the current expression type+ -> Bool -- ^ If matched type is found+hieMatchPatternType arr pat i = curFlat `satisfyPattern` pat+ where+ curFlat :: HieTypeFlat+ curFlat = arr Arr.! i++ match :: PatternType -> TypeIndex -> Bool+ match = hieMatchPatternType arr++ satisfyPattern :: HieTypeFlat -> PatternType -> Bool+ satisfyPattern _ PatternTypeAnything = True+ satisfyPattern t (PatternTypeNeg p) =+ not (satisfyPattern t p)+ satisfyPattern t (PatternTypeOr p1 p2) =+ satisfyPattern t p1+ || satisfyPattern t p2+ satisfyPattern t (PatternTypeAnd p1 p2) =+ satisfyPattern t p1+ && satisfyPattern t p2+ satisfyPattern (HTyVarTy name) (PatternTypeName nameMeta []) =+ compareNames nameMeta name+ satisfyPattern+ (HTyConApp IfaceTyCon{..} (HieArgs hieArgs))+ (PatternTypeName nameMeta args)+ =+ ifaceTyConIsPromoted ifaceTyConInfo == NotPromoted+ && compareNames nameMeta ifaceTyConName+ && checkWith (\(_, ix) a -> match a ix) hieArgs args+ satisfyPattern (HFunTy i1 i2) (PatternTypeFun p1 p2) =+ match p1 i1+ && match p2 i2+ satisfyPattern (HQualTy _ ix) p = match p ix+ satisfyPattern (HForAllTy _ ix) p = match p ix+ satisfyPattern _flat _p = False
+ src/Stan/Info.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE TemplateHaskell #-}++{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++@stan@ build information.+-}++module Stan.Info+ ( -- * Version+ StanVersion (..)+ , stanVersion+ , prettyStanVersion++ -- * System+ , StanSystem (..)+ , stanSystem++ -- * Env+ , StanEnv (..)++ -- * Project Info+ , ProjectInfo (..)+ ) where++import Colourista (blue, bold, formatWith)+import Data.Version (showVersion)+import Development.GitRev (gitCommitDate, gitHash)+import System.Info (arch, compilerName, compilerVersion, os)++import qualified Paths_stan as Meta (version)+++-- | @stan@ version information.+data StanVersion = StanVersion+ { svVersion :: !String+ , svGitRevision :: !String+ , svCommitDate :: !String+ } deriving stock (Show, Eq)++{- | Current @stan@ version information.+-}+stanVersion :: StanVersion+stanVersion = StanVersion+ { svVersion = showVersion Meta.version+ , svGitRevision = $(gitHash)+ , svCommitDate = $(gitCommitDate)+ }++{- | Colourful pretty 'StanVersion' representation used in the @CLI@.+-}+prettyStanVersion :: StanVersion -> String+prettyStanVersion StanVersion{..} = toString $ intercalate "\n"+ [ sVersion+ , sHash+ , sDate+ ]+ where+ fmt :: String -> String+ fmt = formatWith [blue, bold]++ sVersion, sHash, sDate :: String+ sVersion = fmt $ "Stan " <> "v" <> svVersion+ sHash = " ➤ " <> fmt "Git revision: " <> svGitRevision+ sDate = " ➤ " <> fmt "Commit date: " <> svCommitDate++{- | Contains all @stan@ System information+-}+data StanSystem = StanSystem+ { ssOs :: !String+ , ssArch :: !String+ , ssCompiler :: !String+ , ssCompilerVersion :: !String+ } deriving stock (Show, Eq)++-- | All system info for the project+stanSystem :: StanSystem+stanSystem = StanSystem+ { ssOs = os+ , ssArch = arch+ , ssCompiler = compilerName+ , ssCompilerVersion = showVersion compilerVersion+ }++{- | Data from different environment resources:++* Environment variables+* Used TOML configuration files+* Command Line arguments+-}+data StanEnv = StanEnv+ { seEnvVars :: !Text+ , seTomlFiles :: ![FilePath]+ , seCliArgs :: ![String]+ } deriving stock (Show, Eq)+++data ProjectInfo = ProjectInfo+ { piName :: !String+ , piCabalFiles :: ![FilePath]+ , piHieDir :: !FilePath+ , piFileNumber :: !Int+ } deriving stock (Show, Eq)
+ src/Stan/Inspection.hs view
@@ -0,0 +1,163 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++__Inspection__ — check or test provided by Stan.+-}++module Stan.Inspection+ ( -- * Stan inspection type+ Inspection (..)+ , categoryL+ , descriptionL+ , solutionL+ , severityL+ , analysisL++ -- * Inspection info+ , InspectionAnalysis (..)+ , InspectionsMap++ -- * Sorting+ , sortById+ -- * Pretty print+ , prettyShowInspection+ , prettyShowInspectionShort+ -- ** Markdown+ , inspectionsMd+ ) where++import Relude.Extra.Lens (Lens', lens)++import Colourista (blue, bold, formatWith, green)+import Colourista.Short (b, i)++import Stan.Category (Category (..), prettyShowCategory)+import Stan.Core.Id (Id (..))+import Stan.Pattern.Ast (PatternAst)+import Stan.Severity (Severity, prettyShowSeverity)++import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+++{- | Data type that represents a check/test, or how we call it+__inspection__ that is provided by the Stan tool.+-}+data Inspection = Inspection+ { inspectionId :: !(Id Inspection)+ , inspectionName :: !Text+ , inspectionDescription :: !Text+ , inspectionSolution :: ![Text]+ , inspectionCategory :: !(NonEmpty Category)+ , inspectionSeverity :: !Severity+ , inspectionAnalysis :: !InspectionAnalysis+ } deriving stock (Show, Eq)++descriptionL :: Lens' Inspection Text+descriptionL = lens+ inspectionDescription+ (\inspection new -> inspection { inspectionDescription = new })++solutionL :: Lens' Inspection [Text]+solutionL = lens+ inspectionSolution+ (\inspection new -> inspection { inspectionSolution = new })++categoryL :: Lens' Inspection (NonEmpty Category)+categoryL = lens+ inspectionCategory+ (\inspection new -> inspection { inspectionCategory = new })++severityL :: Lens' Inspection Severity+severityL = lens+ inspectionSeverity+ (\inspection new -> inspection { inspectionSeverity = new })++analysisL :: Lens' Inspection InspectionAnalysis+analysisL = lens+ inspectionAnalysis+ (\inspection new -> inspection { inspectionAnalysis = new })++{- | Type alias for the 'HashMap' that contains pairs of inspections 'Id's and+corresponding 'Inspection's.+-}+type InspectionsMap = HashMap (Id Inspection) Inspection++-- | Sort 'Inspection' by 'Id'+sortById :: InspectionsMap -> [Inspection]+sortById = sortWith inspectionId . HM.elems++{- | Data type that represents all possible types of @stan@+inspections in a uniformed way.+-}+data InspectionAnalysis+ -- | Find the specific part of the Haskell AST (including specific functions).+ = FindAst !PatternAst+ -- | Find all operators without matching @infix[r|l]@+ | Infix+ -- | Check if the data type has lazy fields+ | LazyField+ -- | Usage of tuples with size >= 4+ | BigTuples+ -- | Pattern matching on @_@ for sum types.+ | PatternMatchOn_+ -- | Replace multiple comparison operations with 'compare'+ | UseCompare+ deriving stock (Show, Eq)++-- | Show 'Inspection' in a human-friendly format.+prettyShowInspection :: Inspection -> Text+prettyShowInspection Inspection{..} = unlines $+ [ b "~~~STAN INSPECTION~~~"+ , ""+ , i " ✲ ID: " <> b (unId inspectionId)+ , i " ✲ Name: " <> inspectionName+ , i " ✲ Description: " <> inspectionDescription+ , i " ✲ Severity: " <> prettyShowSeverity inspectionSeverity+ , i " ✲ Category: " <> T.intercalate " " (map prettyShowCategory $ toList inspectionCategory)+ , ""+ , formatWith [green] "Possible solutions:"+ ] <> map (" - " <>) inspectionSolution++-- | Show the short view of a given 'Inspection'.+prettyShowInspectionShort :: Inspection -> Text+prettyShowInspectionShort Inspection{..} =+ " ❋ "+ <> formatWith [bold, blue] ("[" <> unId inspectionId <> "] ")+ <> i inspectionName++{- | Create the MarkDown text for all inspections.+The generated MD has a ToC and separate sections for each inspection.++This is used to keep the Wiki page of the project up to date.+-}+inspectionsMd :: [Inspection] -> Text+inspectionsMd inss = intro <> toc <> unlines (map inspectionToMd inss)+ where+ intro :: Text+ intro = "This document contains information about all inspections used in Stan to find observations in your projects. Below you can see more details about each inspection individually\n\n"++ toc :: Text+ toc = "## Table of all Inspections\n\n" <> unlines (map insLink inss) <> "\n"++ insLink :: Inspection -> Text+ insLink (unId . inspectionId -> ins)= " * [" <> ins <> "](#" <> ins <> ")"++inspectionToMd :: Inspection -> Text+inspectionToMd Inspection{..} = unlines $+ [ "## " <> unId inspectionId+ , ""+ , "[[Back to the Table of all Inspections] ↑](#table-of-all-inspections)"+ , ""+ , "| Property | Value |"+ , "|--|--|"+ , "| ID | " <> unId inspectionId <> " |"+ , "| Name | " <> inspectionName <> " |"+ , "| Description | " <> inspectionDescription <> " |"+ , "| Severity | " <> show inspectionSeverity <> " |"+ , "| Category | " <> "#" <> T.intercalate " #" (map unCategory $ toList inspectionCategory) <> " |"+ , ""+ , "#### Possible solutions for " <> unId inspectionId+ ] <> map (" - " <>) inspectionSolution
+ src/Stan/Inspection/All.hs view
@@ -0,0 +1,55 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Contains lists of all 'Inspection's and 'Inspection' 'Id's provided by @Stan@.+-}++module Stan.Inspection.All+ ( inspectionsMap+ , inspections+ , inspectionsIds++ -- * Stan inspections search+ , lookupInspectionById+ , getInspectionById+ ) where++import Stan.Core.Id (Id (..))+import Stan.Inspection (Inspection (..), InspectionsMap)+import Stan.Inspection.AntiPattern (antiPatternInspectionsMap)+import Stan.Inspection.Infinite (infiniteInspectionsMap)+import Stan.Inspection.Partial (partialInspectionsMap)+import Stan.Inspection.Style (styleInspectionsMap)++import qualified Data.HashMap.Strict as HM+++-- | All 'Inspection's map from 'Id's.+inspectionsMap :: InspectionsMap+inspectionsMap =+ partialInspectionsMap+ <> infiniteInspectionsMap+ <> antiPatternInspectionsMap+ <> styleInspectionsMap++{- | List of all inspections.+-}+inspections :: [Inspection]+inspections = sortWith inspectionId $ HM.elems inspectionsMap++-- | Set of all inspection 'Id's.+inspectionsIds :: HashSet (Id Inspection)+inspectionsIds = HM.keysSet inspectionsMap++-- | Look up 'Inspection' by the given inspection 'Id'.+lookupInspectionById :: Id Inspection -> Maybe Inspection+lookupInspectionById insId = HM.lookup insId inspectionsMap+{-# INLINE lookupInspectionById #-}++-- | Get the 'Inspection' by the given known inspection 'Id'.+getInspectionById :: Id Inspection -> Inspection+getInspectionById insId = case lookupInspectionById insId of+ Just ins -> ins+ Nothing -> error $ "Unknown Inspection ID: " <> unId insId
+ src/Stan/Inspection/AntiPattern.hs view
@@ -0,0 +1,390 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Contains all 'Inspection's for known anti-patterns.++The __anti-pattern__ inspections are in ranges:++* @STAN-0201 .. STAN-0300@++-}++module Stan.Inspection.AntiPattern+ ( -- * Anti-pattern inspections+ -- *** Anti-pattern @[0 .. length xs]@+ stan0201+ -- *** Anti-pattern 'foldl'+ , stan0202+ -- *** Anti-pattern 'Data.ByteString.Char8.pack'+ , stan0203+ -- *** Anti-pattern slow 'size' for 'HashMap'+ , stan0204+ -- *** Anti-pattern slow 'size' for 'HashSet'+ , stan0205+ -- *** Anti-pattern: Lazy fields+ , stan0206+ -- *** Anti-pattern: Foldable methods on tuples, 'Maybe', 'Either'+ , stan0207+ -- *** Anti-pattern: slow 'length' for 'Text'+ , stan0208+ -- *** Anti-pattern: Slow 'nub' for lists+ , stan0209+ -- *** Anti-pattern: Slow 'for_' on ranges+ , stan0210+ -- *** Anti-pattern: '</>' for URLs+ , stan0211+ -- *** Anti-pattern: unsafe functions+ , stan0212+ -- *** Anti-pattern: Pattern-matching on @_@+ , stan0213+ -- *** Anti-pattern: use 'compare'+ , stan0214+ -- *** Anti-pattern: Slashes in paths+ , stan0215++ -- * All inspections+ , antiPatternInspectionsMap+ ) where++import Relude.Extra.Lens ((%~), (.~))+import Relude.Extra.Tuple (fmapToFst)++import Stan.Core.Id (Id (..))+import Stan.Inspection (Inspection (..), InspectionAnalysis (..), InspectionsMap, categoryL,+ descriptionL, severityL, solutionL)+import Stan.NameMeta (NameMeta (..), baseNameFrom, mkBaseFoldableMeta, mkBaseOldListMeta,+ primTypeMeta, textNameFrom, unorderedNameFrom)+import Stan.Pattern.Ast (Literal (..), PatternAst (..), anyNamesToPatternAst, app,+ namesToPatternAst, opApp, range)+import Stan.Pattern.Edsl (PatternBool (..))+import Stan.Pattern.Type (PatternType, charPattern, foldableMethodsPatterns, foldableTypesPatterns,+ listPattern, stringPattern, textPattern, (|->), (|::))+import Stan.Severity (Severity (..))++import qualified Data.List.NonEmpty as NE+import qualified Stan.Category as Category+++-- | All anti-pattern 'Inspection's map from 'Id's.+antiPatternInspectionsMap :: InspectionsMap+antiPatternInspectionsMap = fromList $ fmapToFst inspectionId+ [ stan0201+ , stan0202+ , stan0203+ , stan0204+ , stan0205+ , stan0206+ , stan0207+ , stan0208+ , stan0209+ , stan0210+ , stan0211+ , stan0212+ , stan0213+ , stan0214+ , stan0215+ ]++-- | Smart constructor to create anti-pattern 'Inspection'.+mkAntiPatternInspection :: Id Inspection -> Text -> InspectionAnalysis -> Inspection+mkAntiPatternInspection insId name inspectionAnalysis = Inspection+ { inspectionId = insId+ , inspectionName = "Anti-pattern: " <> name+ , inspectionDescription = ""+ , inspectionSolution = []+ , inspectionCategory = Category.antiPattern :| []+ , inspectionSeverity = PotentialBug+ , ..+ }++-- | 'Inspection' — @[0 .. length xs]@ @STAN-0201@.+stan0201 :: Inspection+stan0201 = mkAntiPatternInspection (Id "STAN-0201") "[0 .. length xs]" (FindAst lenPatAst)+ & descriptionL .~ "Creating a list with wrong number of indices"+ & solutionL .~+ [ "Replace '[0 .. length xs]' with '[0 .. length xs - 1]'"+ , "Use 'zip [0 ..] xs` to work with list of pairs: index and element"+ ]+ where+ lenPatAst :: PatternAst+ lenPatAst = range+ (PatternAstConstant $ ExactNum 0)+ (app+ (PatternAstName (mkBaseFoldableMeta "length") (?))+ (?)+ )++-- | 'Inspection' — 'foldl' @STAN-0202@.+stan0202 :: Inspection+stan0202 = mkAntiPatternInspection (Id "STAN-0202") "foldl"+ (FindAst $ PatternAstName (mkBaseFoldableMeta "foldl") (?))+ & descriptionL .~ "Usage of space-leaking function 'foldl'"+ & solutionL .~+ [ "Replace 'foldl' with 'foldl''"+ , "Use 'foldr (flip . f)` instead of 'foldl f'"+ ]+ & severityL .~ Error+ & categoryL %~ (Category.spaceLeak `NE.cons`)++-- | 'Inspection' — 'Data.ByteString.Char8.pack' @STAN-0203@.+stan0203 :: Inspection+stan0203 = mkAntiPatternInspection (Id "STAN-0203") "Data.ByteString.Char8.pack"+ (FindAst $ PatternAstName packNameMeta (?))+ & descriptionL .~ "Usage of 'pack' function that doesn't handle Unicode characters"+ & solutionL .~+ [ "Convert to 'Text' and use 'encodeUtf8' from 'Data.Text.Encoding'"+ , "{Extra dependency} Use 'encodeUtf8' from 'relude'"+ , "{Extra dependency} Use the 'utf8-string' package"+ ]+ & severityL .~ Error+ where+ packNameMeta :: NameMeta+ packNameMeta = NameMeta+ { nameMetaPackage = "bytestring"+ , nameMetaModuleName = "Data.ByteString.Char8"+ , nameMetaName = "pack"+ }++-- | 'Inspection' — slow 'Data.HashMap.Strict.size' and 'length' @STAN-0204@.+stan0204 :: Inspection+stan0204 = mkAntiPatternInspection (Id "STAN-0204") "HashMap size"+ (FindAst $ namesToPatternAst pats)+ & descriptionL .~ "Usage of 'size' or 'length' for 'HashMap' that runs in linear time"+ & solutionL .~+ [ "{Extra dependency} Switch to 'Map' from 'containers'"+ ]+ & severityL .~ Performance+ where+ pats :: NonEmpty (NameMeta, PatternType)+ pats = (sizeNameMeta, (?))+ :| [(mkBaseFoldableMeta "length", hmPat)]++ sizeNameMeta :: NameMeta+ sizeNameMeta = "size" `unorderedNameFrom` "Data.HashMap.Base"++ hm :: NameMeta+ hm = "HashMap" `unorderedNameFrom` "Data.HashMap.Base"++ hmPat :: PatternType+ hmPat = (hm |:: [(?), (?)]) |-> (?)++-- | 'Inspection' — slow 'Data.HashMap.Strict.size' @STAN-0205@.+stan0205 :: Inspection+stan0205 = mkAntiPatternInspection (Id "STAN-0205") "HashSet size"+ (FindAst $ namesToPatternAst pats)+ & descriptionL .~ "Usage of 'size' or 'length' for 'HashSet' that runs in linear time"+ & solutionL .~+ [ "{Extra dependency} Switch to 'Set' from 'containers'"+ ]+ & severityL .~ Performance+ where+ pats :: NonEmpty (NameMeta, PatternType)+ pats = (sizeNameMeta, (?))+ :| [(mkBaseFoldableMeta "length", hsPat)]++ sizeNameMeta :: NameMeta+ sizeNameMeta = "size" `unorderedNameFrom` "Data.HashSet.Base"++ hs :: NameMeta+ hs = "HashSet" `unorderedNameFrom` "Data.HashSet.Base"++ hsPat :: PatternType+ hsPat = (hs |:: [(?)]) |-> (?)++-- | 'Inspection' — missing strictness declaration @STAN-0206@.+stan0206 :: Inspection+stan0206 = Inspection+ { inspectionId = Id "STAN-0206"+ , inspectionName = "Data types with non-strict fields"+ , inspectionDescription =+ "Defining lazy fields in data types can lead to unexpected space leaks"+ , inspectionSolution =+ [ "Add '!' before the type, e.g. !Int or !(Maybe Bool)"+ , "Enable the 'StrictData' extension: {-# LANGUAGE StrictData #-}"+ ]+ , inspectionCategory = Category.spaceLeak :| [Category.syntax]+ , inspectionSeverity = Performance+ , inspectionAnalysis = LazyField+ }++-- | 'Inspection' — 'Foldable' methods on possibly error-prone structures @STAN-0207@.+stan0207 :: Inspection+stan0207 = mkAntiPatternInspection+ (Id "STAN-0207")+ "Foldable methods on possibly error-prone structures"+ (FindAst $ namesToPatternAst allPatterns)+ & descriptionL .~ "Usage of Foldable methods on (,), Maybe, Either"+ & solutionL .~+ [ "Use more explicit functions with specific monomorphic types"+ ]+ where+ allPatterns :: NonEmpty (NameMeta, PatternType)+ allPatterns = do -- Monad for NonEmpty+ t <- foldableTypesPatterns+ (method, mkType) <- foldableMethodsPatterns+ pure (method, mkType t)++-- | 'Inspection' — slow 'length' for 'Data.Text' @STAN-0208@.+stan0208 :: Inspection+stan0208 = mkAntiPatternInspection (Id "STAN-0208") "Slow 'length' for Text"+ (FindAst $ PatternAstName lenNameMeta (textPattern |-> (?)))+ & descriptionL .~ "Usage of 'length' for 'Text' that runs in linear time"+ & solutionL .~+ [ "{Extra dependency} Switch to 'ByteString' from 'bytesting'"+ ]+ & severityL .~ Performance+ where+ lenNameMeta :: NameMeta+ lenNameMeta = "length" `textNameFrom` "Data.Text"++-- | 'Inspection' — slow 'nub' for lists @STAN-0209@.+stan0209 :: Inspection+stan0209 = mkAntiPatternInspection (Id "STAN-0209") "Slow 'nub' for lists"+ (FindAst $ PatternAstName (mkBaseOldListMeta "nub") $ listPattern |-> listPattern)+ & descriptionL .~ "Usage of 'nub' on lists that runs in quadratic time"+ & solutionL .~+ [ "{Extra dependency} Switch list to 'Set' from 'containers'"+ , "{Extra dependency} Use 'ordNub/hashNub/sortNub/unstableNub' from 'relude'"+ , "{Extra dependency} Use 'nubOrd' from 'containers'"+ , "{Extra dependency} Use 'nubOrd' from 'extra'"+ ]+ & severityL .~ Performance++-- | 'Inspection' — slow 'for_' and 'forM_' for ranges @STAN-0210@.+stan0210 :: Inspection+stan0210 = mkAntiPatternInspection (Id "STAN-0210") "Slow 'for_' on ranges" (FindAst pat)+ & descriptionL .~ "Usage of 'for_' or 'forM_' on numerical ranges is slow"+ & solutionL .~+ [ "{Extra dependency} Use 'loop' library for fast monadic looping"+ ]+ & severityL .~ Performance+ where+ pat :: PatternAst+ pat = app forPattern (range (?) (?))++ forPattern :: PatternAst+ forPattern = PatternAstOr+ (PatternAstName (mkBaseFoldableMeta "for_") forType)+ (PatternAstName (mkBaseFoldableMeta "forM_") forType)++ forType :: PatternType+ forType = listPattern |-> ((?) |-> (?)) |-> (?)++-- | 'Inspection' — @</>@ on URLs @STAN-0211@.+stan0211 :: Inspection+stan0211 = mkAntiPatternInspection (Id "STAN-0211") "'</>' for URLs" (FindAst pat)+ & descriptionL .~ "Usage of '</>' for URLs results in the errors on Windows"+ & solutionL .~+ [ "{Extra dependency} Use type-safe library for URLs"+ , "Concatenate URLs with slashes '/'"+ ]+ & severityL .~ Error+ where+ pat :: PatternAst+ pat = opApp (httpLit ||| urlName) filepathOperator (?)+ ||| opApp (?) filepathOperator urlName++ httpLit :: PatternAst+ httpLit = startWith "\"http:"+ ||| startWith "\"https:"+ ||| startWith "\"ftp:"+ ||| startWith "\"mailto:"+ ||| startWith "\"file:"+ ||| startWith "\"data:"+ ||| startWith "\"irc:"+ where+ startWith :: ByteString -> PatternAst+ startWith = PatternAstConstant . PrefixStr++ urlName :: PatternAst+ urlName = PatternAstVarName "url"++filepathOperator :: PatternAst+filepathOperator = PatternAstName operatorPosix fun+ ||| PatternAstName operatorWindows fun+ where+ operatorPosix :: NameMeta+ operatorPosix = NameMeta+ { nameMetaName = "</>"+ , nameMetaModuleName = "System.FilePath.Posix"+ , nameMetaPackage = "filepath"+ }++ operatorWindows :: NameMeta+ operatorWindows = NameMeta+ { nameMetaName = "</>"+ , nameMetaModuleName = "System.FilePath.Windows"+ , nameMetaPackage = "filepath"+ }++ fun :: PatternType+ fun = (?) |-> filePathType |-> (?)++ {- TODO: Note, that at the moment hie somehow thinks that '</>' works with+ 'String's even when I specify type of vars to 'FilePath' explicitly.+ This is odd and needs more investigation.+ -}+ filePathType :: PatternType+ filePathType = "FilePath" `baseNameFrom` "GHC.IO" |:: []+ ||| stringPattern+ ||| primTypeMeta "[]" |:: [ charPattern ]++-- | 'Inspection' — usage of @unsafe*@ functions @STAN-0212@.+stan0212 :: Inspection+stan0212 = mkAntiPatternInspection (Id "STAN-0212") "unsafe functions" (FindAst pat)+ & descriptionL .~ "Usage of unsafe functions breaks referential transparency"+ & solutionL .~+ [ "Remove 'undefined' or at least replace with 'error' to give better error messages"+ , "Replace 'unsafeCoerce' with 'coerce'"+ , "Rewrite the code to avoid using 'unsafePerformIO' and other unsafe IO functions"+ ]+ & severityL .~ Error+ & categoryL %~ (Category.unsafe `NE.cons`)+ where+ pat :: PatternAst+ pat = anyNamesToPatternAst+ $ "undefined" `baseNameFrom` "GHC.Err" :|+ [ "unsafeCoerce" `baseNameFrom` "Unsafe.Coerce"+ , "unsafePerformIO" `baseNameFrom` "GHC.IO.Unsafe"+ , "unsafeInterleaveIO" `baseNameFrom` "GHC.IO.Unsafe"+ , "unsafeDupablePerformIO" `baseNameFrom` "GHC.IO.Unsafe"+ , "unsafeFixIO" `baseNameFrom` "System.IO.Unsafe"+ ]++-- | 'Inspection' — Pattent matching on @_@ for sum types — @STAN-0213@.+stan0213 :: Inspection+stan0213 = mkAntiPatternInspection (Id "STAN-0213") "Pattern matching on '_'" PatternMatchOn_+ & descriptionL .~ "Pattern matching on '_' for sum types can create maintainability issues"+ & solutionL .~+ [ "Pattern match on each constructor explicitly"+ , "Add meaningful names to holes, e.g. '_anyOtherFailure'"+ ]+ & severityL .~ Warning++-- | 'Inspection' — use 'compare' @STAN-0214@.+stan0214 :: Inspection+stan0214 = mkAntiPatternInspection (Id "STAN-0214") "use 'compare'" UseCompare+ & descriptionL .~ "Usage of multiple comparison operators instead of single 'compare'"+ & solutionL .~+ [ "Rewrite code to use single 'compare' instead of many comparison operators"+ ]+ & severityL .~ Performance++-- | 'Inspection' — Slashes in paths @STAN-0215@.+stan0215 :: Inspection+stan0215 = mkAntiPatternInspection (Id "STAN-0215") "Slashes in paths" (FindAst pat)+ & descriptionL .~ "Usage of '/' or '\\' in paths results in the errors on different operation systems"+ & solutionL .~+ [ "{Extra dependency} Use '</>' operator from 'filepath'"+ ]+ & severityL .~ Error+ where+ pat :: PatternAst+ pat = opApp pathLit filepathOperator (?)+ ||| opApp (?) filepathOperator pathLit++ pathLit :: PatternAst+ pathLit = PatternAstConstant (ContainStr "/")+ ||| PatternAstConstant (ContainStr "\\\\")
+ src/Stan/Inspection/Infinite.hs view
@@ -0,0 +1,96 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Contains all 'Inspection's for functions that hang on infinite lists.++The __infinite__ inspections are in ranges:++* @STAN-0101 .. STAN-0200@+-}++module Stan.Inspection.Infinite+ ( -- * Infinite inspections+ -- *** Infinite 'GHC.List.reverse'+ stan0101+ -- *** Infinite 'Data.OldList.isSuffixOf'+ , stan0102+ -- *** Infinite 'Data.Foldable.length'+ , stan0103+ -- *** Infinite 'Data.OldList.genericLength'+ , stan0104+ -- *** Infinite 'Data.Foldable.sum'+ , stan0105+ -- *** Infinite 'Data.Foldable.product'+ , stan0106++ -- * All inspections+ , infiniteInspectionsMap+ ) where++import Relude.Extra.Tuple (fmapToFst)++import Stan.Core.Id (Id (..))+import Stan.Inspection (Inspection (..), InspectionAnalysis (..), InspectionsMap)+import Stan.NameMeta (NameMeta (..), mkBaseFoldableMeta, mkBaseListMeta, mkBaseOldListMeta)+import Stan.Pattern.Ast (namesToPatternAst)+import Stan.Pattern.Edsl (PatternBool (..))+import Stan.Pattern.Type (PatternType (..), listFunPattern)+import Stan.Severity (Severity (..))++import qualified Stan.Category as Category+++-- | All infinite 'Inspection's map from 'Id's.+infiniteInspectionsMap :: InspectionsMap+infiniteInspectionsMap = fromList $ fmapToFst inspectionId+ [ stan0101+ , stan0102+ , stan0103+ , stan0104+ , stan0105+ , stan0106+ ]++-- | Smart constructor to create infinite 'Inspection'.+mkInfiniteInspection :: Id Inspection -> NonEmpty (NameMeta, PatternType) -> Inspection+mkInfiniteInspection insId pats@((NameMeta{..},_) :| _) = Inspection+ { inspectionId = insId+ , inspectionName = "Infinite: " <> nameMetaPackage <> "/" <> nameMetaName+ , inspectionDescription =+ "Usage of the '" <> nameMetaName <> "' function that hangs on infinite lists"+ , inspectionSolution =+ [ "Don't use '" <> nameMetaName <> "' if you expect your function to work with infinite lists"+ , "{Extra dependency} Use the 'slist' library for fast and safe functions on infinite lists"+ ]+ , inspectionCategory = Category.infinite :| [Category.list]+ , inspectionSeverity = PotentialBug+ , inspectionAnalysis = FindAst $ namesToPatternAst pats+ }++-- | 'Inspection' for 'stan0101' — infinite 'reverse' @STAN-0101@.+stan0101 :: Inspection+stan0101 = mkInfiniteInspection (Id "STAN-0101") $ one (mkBaseListMeta "reverse", (?))++-- | 'Inspection' for 'stan0102' — infinite 'Data.OldList.isSuffixOf' @STAN-0102@.+stan0102 :: Inspection+stan0102 = mkInfiniteInspection (Id "STAN-0102") $ one (mkBaseOldListMeta "isSuffixOf", (?))++-- | 'Inspection' for 'stan0103' — infinite 'Data.Foldable.length' | 'Data.OldList.length' @STAN-0103@.+stan0103 :: Inspection+stan0103 = mkInfiniteInspection (Id "STAN-0103") $+ (mkBaseFoldableMeta "length", listFunPattern)+ :| [(mkBaseListMeta "length", listFunPattern)]++-- | 'Inspection' for 'stan0104' — infinite 'Data.OldList.genericLength' @STAN-0104@.+stan0104 :: Inspection+stan0104 = mkInfiniteInspection (Id "STAN-0104") $ one (mkBaseOldListMeta "genericLength", (?))++-- | 'Inspection' for 'stan0105' — infinite 'Data.Foldable.sum' @STAN-0105@.+stan0105 :: Inspection+stan0105 = mkInfiniteInspection (Id "STAN-0105") $ one (mkBaseFoldableMeta "sum", listFunPattern)++-- | 'Inspection' for 'stan0106' — infinite 'Data.Foldable.product' @STAN-0106@.+stan0106 :: Inspection+stan0106 = mkInfiniteInspection (Id "STAN-0106") $ one (mkBaseFoldableMeta "product", listFunPattern)
+ src/Stan/Inspection/Partial.hs view
@@ -0,0 +1,289 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Contains all 'Inspection's for partial functions.++The __partial__ inspections are in ranges:++* @STAN-0001 .. STAN-0100@+-}++module Stan.Inspection.Partial+ ( -- * Partial 'Inspection's+ -- *** Partial 'GHC.List.head'+ stan0001+ -- *** Partial 'GHC.List.tail'+ , stan0002+ -- *** Partial 'GHC.List.init'+ , stan0003+ -- *** Partial 'GHC.List.last'+ , stan0004+ -- *** Partial 'GHC.List.!!'+ , stan0005+ -- *** Partial 'GHC.List.cycle'+ , stan0006+ -- *** Partial 'Data.OldList.genericIndex'+ , stan0007+ -- *** Partial 'Data.Maybe.fromJust'+ , stan0008+ -- *** Partial 'Text.Read.read'+ , stan0009+ -- *** Partial 'GHC.Enum.succ'+ , stan0010+ -- *** Partial 'GHC.Enum.pred'+ , stan0011+ -- *** Partial 'GHC.Enum.toEnum'+ , stan0012+ -- *** Partial 'Data.Foldable.maximum'+ , stan0013+ -- *** Partial 'Data.Foldable.minimum'+ , stan0014+ -- *** Partial 'Data.Foldable.maximumBy'+ , stan0015+ -- *** Partial 'Data.Foldable.minimumBy'+ , stan0016+ -- *** Partial 'Data.Foldable.foldl1'+ , stan0017+ -- *** Partial 'Data.Foldable.foldl1\''+ , stan0018+ -- *** Partial 'Data.Foldable.foldr1'+ , stan0019+ -- *** Partial instance for 'NonEmpty' method 'GHC.Exts.fromList'+ , stan0020+ -- *** Partial instance for 'Natural' method 'GHC.Num.fromInteger'+ , stan0021++ -- * List of all partial 'Inspection's+ , partialInspectionsMap+ ) where++import Prelude hiding ((&&&))+import Relude.Extra.Lens ((%~), (.~))+import Relude.Extra.Tuple (fmapToFst)++import Stan.Core.Id (Id (..))+import Stan.Inspection (Inspection (..), InspectionAnalysis (..), InspectionsMap, analysisL,+ categoryL, descriptionL, solutionL)+import Stan.NameMeta (NameMeta (..), baseNameFrom, mkBaseFoldableMeta, mkBaseListMeta,+ mkBaseOldListMeta)+import Stan.Pattern.Ast (PatternAst (PatternAstName), namesToPatternAst)+import Stan.Pattern.Edsl (PatternBool (..))+import Stan.Pattern.Type (PatternType (..), integerPattern, listFunPattern, listPattern,+ naturalPattern, nonEmptyPattern, (|->))+import Stan.Severity (Severity (..))++import qualified Stan.Category as Category+++-- | All partial 'Inspection's.+partialInspectionsMap :: InspectionsMap+partialInspectionsMap = fromList $ fmapToFst inspectionId+ [ stan0001+ , stan0002+ , stan0003+ , stan0004+ , stan0005+ , stan0006+ , stan0007+ , stan0008+ , stan0009+ , stan0010+ , stan0011+ , stan0012+ , stan0013+ , stan0014+ , stan0015+ , stan0016+ , stan0017+ , stan0018+ , stan0019+ , stan0020+ , stan0021+ ]++-- | Smart constructor to create generic partial 'Inspection' with a given 'Pattern'.+mkPartialInspectionPattern+ :: Id Inspection+ -> NameMeta+ -> PatternType+ -> Text -- ^ Type name+ -> Inspection+mkPartialInspectionPattern insId nameMeta@NameMeta{..} pat typeName = Inspection+ { inspectionId = insId+ , inspectionName = "Partial: " <> nameMetaPackage <> "/" <> nameMetaName+ , inspectionDescription = usage nameMetaName typeName+ , inspectionSolution = []+ , inspectionCategory = one Category.partial+ , inspectionSeverity = Warning+ , inspectionAnalysis = FindAst $ PatternAstName nameMeta pat+ }++-- | Smart constructor to create generic partial 'Inspection' with 'PatternAnything'.+mkPartialInspection+ :: Id Inspection+ -> NameMeta+ -> Text -- ^ Type name+ -> Inspection+mkPartialInspection insId nameMeta =+ mkPartialInspectionPattern insId nameMeta (?)++usage :: Text -> Text -> Text+usage funName forWhat =+ "Usage of partial function '" <> funName <> "' for " <> forWhat++{- | Smart constructor to create partial 'Inspection' for functions+that work with lists.+-}+mkPartialInspectionList :: Id Inspection -> NameMeta -> Inspection+mkPartialInspectionList insId nameMeta = mkPartialInspection insId nameMeta "lists"+ & categoryL %~ (<> one Category.list)+ & solutionL .~+ [ "Replace list with 'NonEmpty' from 'Data.List.NonEmpty'"+ , "Use explicit pattern-matching over lists"+ ]++{- | Smart constructor to create partial 'Inspection' for functions+that work with enumerable types.+-}+mkPartialInspectionEnum :: Id Inspection -> Text -> PatternType -> [Text] -> Inspection+mkPartialInspectionEnum insId funName pat solution =+ mkPartialInspectionPattern insId enumMeta pat ""+ & descriptionL .~ usage funName "enumerable types"+ & solutionL .~ solution+ where+ enumMeta :: NameMeta+ enumMeta = funName `baseNameFrom` "GHC.Enum"++-- | 'Inspection' — partial 'GHC.List.head' @STAN-0001@.+stan0001 :: Inspection+stan0001 = mkPartialInspectionList (Id "STAN-0001") (mkBaseListMeta "head")++-- | 'Inspection' — partial 'GHC.List.tail' @STAN-0002@.+stan0002 :: Inspection+stan0002 = mkPartialInspectionList (Id "STAN-0002") (mkBaseListMeta "tail")++-- | 'Inspection' — partial 'GHC.List.init' @STAN-0003@.+stan0003 :: Inspection+stan0003 = mkPartialInspectionList (Id "STAN-0003") (mkBaseListMeta "init")++-- | 'Inspection' — partial 'GHC.List.last' @STAN-0004@.+stan0004 :: Inspection+stan0004 = mkPartialInspectionList (Id "STAN-0004") (mkBaseListMeta "last")++-- | 'Inspection' — partial 'GHC.List.!!' @STAN-0005@.+stan0005 :: Inspection+stan0005 = mkPartialInspectionList (Id "STAN-0005") (mkBaseListMeta "!!")+ & solutionL .~ []++-- | 'Inspection' — partial 'GHC.List.cycle' @STAN-0006@.+stan0006 :: Inspection+stan0006 = mkPartialInspectionList (Id "STAN-0006") (mkBaseListMeta "cycle")++-- | 'Inspection' — partial 'Data.OldList.genericIndex' @STAN-0007@.+stan0007 :: Inspection+stan0007 = mkPartialInspectionList (Id "STAN-0007") (mkBaseOldListMeta "genericIndex")+ & solutionL .~ []++-- | 'Inspection' — partial 'Data.Maybe.fromJust' @STAN-0008@.+stan0008 :: Inspection+stan0008 = mkPartialInspection (Id "STAN-0008") fromJustNameMeta "'Maybe'"+ & solutionL .~+ [ "Use explicit pattern-matching over Maybe"+ , "Use one of the standard functions: 'maybe', 'fromMaybe'"+ ]+ where+ fromJustNameMeta :: NameMeta+ fromJustNameMeta = "fromJust" `baseNameFrom` "Data.Maybe"++-- | 'Inspection' — partial 'Text.Read.read' @STAN-0009@.+stan0009 :: Inspection+stan0009 = mkPartialInspection (Id "STAN-0009") readNameMeta ""+ & descriptionL .~ usage "read" "parsing 'String'"+ & solutionL .~+ [ "Use 'readMaybe' or 'readEither' to handle failed parsing"+ ]+ where+ readNameMeta :: NameMeta+ readNameMeta = "read" `baseNameFrom` "Text.Read"++-- | 'Inspection' — partial 'GHC.Enum.succ' @STAN-0010@.+stan0010 :: Inspection+stan0010 = mkPartialInspectionEnum+ (Id "STAN-0010")+ "succ"+ (neg (integerPattern |-> (?)) &&& neg (naturalPattern |-> (?)))+ [ "Use '(+ 1)' for integral types (but be aware of arithmetic overflow)"+ , "{Extra dependency} Use 'next' from 'Relude.Extra.Enum' in 'relude'"+ ]++-- | 'Inspection' — partial 'GHC.Enum.pred' @STAN-0011@.+stan0011 :: Inspection+stan0011 = mkPartialInspectionEnum+ (Id "STAN-0011")+ "pred"+ (neg (integerPattern |-> (?)))+ [ "Use '(- 1)' for integral types (but be aware of arithmetic overflow)"+ , "{Extra dependency} Use 'prev' from 'Relude.Extra.Enum' in 'relude'"+ ]++-- | 'Inspection' — partial 'GHC.Enum.toEnum' @STAN-0012@.+stan0012 :: Inspection+stan0012 = mkPartialInspectionEnum (Id "STAN-0012") "toEnum" (?)+ [ "{Extra dependency} Use 'safeToEnum' from 'Relude.Extra.Enum' in 'relude'"+ ]++-- | 'Inspection' — partial 'Data.Foldable.maximum' @STAN-0013@.+stan0013 :: Inspection+stan0013 = mkPartialInspectionPattern+ (Id "STAN-0013") (mkBaseFoldableMeta "maximum") listFunPattern ""++-- | 'Inspection' — partial 'Data.Foldable.minimum' @STAN-0014@.+stan0014 :: Inspection+stan0014 = mkPartialInspectionPattern+ (Id "STAN-0014") (mkBaseFoldableMeta "minimum") listFunPattern ""++orderingFunPattern :: PatternType+orderingFunPattern = (?) |-> listFunPattern++-- | 'Inspection' — partial 'Data.Foldable.maximumBy' @STAN-0015@.+stan0015 :: Inspection+stan0015 = mkPartialInspectionPattern+ (Id "STAN-0015") (mkBaseFoldableMeta "maximumBy") orderingFunPattern ""++-- | 'Inspection' — partial 'Data.Foldable.minimumBy' @STAN-0016@.+stan0016 :: Inspection+stan0016 = mkPartialInspectionPattern+ (Id "STAN-0016") (mkBaseFoldableMeta "minimumBy") orderingFunPattern ""++-- | 'Inspection' — partial 'Data.Foldable.foldl1' @STAN-0017@.+stan0017 :: Inspection+stan0017 = mkPartialInspectionPattern+ (Id "STAN-0017") (mkBaseFoldableMeta "foldl1") orderingFunPattern ""++-- | 'Inspection' — partial 'Data.Foldable.foldl1\'' @STAN-0018@.+stan0018 :: Inspection+stan0018 = mkPartialInspectionList (Id "STAN-0018") (mkBaseListMeta "foldl1'")++-- | 'Inspection' — partial 'Data.Foldable.foldr1' @STAN-0019@.+stan0019 :: Inspection+stan0019 = mkPartialInspectionPattern+ (Id "STAN-0019") (mkBaseFoldableMeta "foldr1") orderingFunPattern ""++-- | 'Inspection' — partial 'GHC.Exts.fromList' @STAN-0020@.+stan0020 :: Inspection+stan0020 = mkPartialInspectionPattern (Id "STAN-0020") exts pat ""+ & analysisL .~ FindAst (namesToPatternAst $ (exts, pat) :| [(ne, pat)])+ where+ pat = listPattern |-> nonEmptyPattern+ exts = "fromList" `baseNameFrom` "GHC.Exts"+ ne = "fromList" `baseNameFrom` "Data.List.NonEmpty"++-- | 'Inspection' — partial 'GHC.Num.fromInteger' @STAN-0021@.+stan0021 :: Inspection+stan0021 = mkPartialInspectionPattern+ (Id "STAN-0021")+ ("fromInteger" `baseNameFrom` "GHC.Num")+ (integerPattern |-> naturalPattern)+ ""
+ src/Stan/Inspection/Style.hs view
@@ -0,0 +1,67 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Contains all 'Inspection's for style improvements.++The __style__ inspections are in ranges:++* @STAN-0301 .. STAN-0400@+-}++module Stan.Inspection.Style+ ( -- * Style inspections+ -- *** Missing fixity+ stan0301+ -- *** Too big tuples+ , stan0302++ -- * All inspections+ , styleInspectionsMap+ ) where++import Relude.Extra.Tuple (fmapToFst)++import Stan.Core.Id (Id (..))+import Stan.Inspection (Inspection (..), InspectionAnalysis (..), InspectionsMap)+import Stan.Severity (Severity (Style))++import qualified Stan.Category as Category+++-- | All anti-pattern 'Inspection's map from 'Id's.+styleInspectionsMap :: InspectionsMap+styleInspectionsMap = fromList $ fmapToFst inspectionId+ [ stan0301+ , stan0302+ ]++-- | 'Inspection' — missing fixity declaration @STAN-0301@.+stan0301 :: Inspection+stan0301 = Inspection+ { inspectionId = Id "STAN-0301"+ , inspectionName = "Missing fixity declaration for operator"+ , inspectionDescription = "Using the implicit default fixity for operator: infixl 9"+ , inspectionSolution =+ [ "Add 'infix[l|r]' declaration to the operator with explicit precedence"+ ]+ , inspectionCategory = Category.syntax :| []+ , inspectionSeverity = Style+ , inspectionAnalysis = Infix+ }++-- | 'Inspection' — to big tuples @STAN-0302@.+stan0302 :: Inspection+stan0302 = Inspection+ { inspectionId = Id "STAN-0302"+ , inspectionName = "Big tuples"+ , inspectionDescription =+ "Using tuples of big size (>= 4) can decrease code readability"+ , inspectionSolution =+ [ "Consider defining and using a custom data type to improve code comprehension"+ ]+ , inspectionCategory = Category.antiPattern :| [Category.syntax]+ , inspectionSeverity = Style+ , inspectionAnalysis = BigTuples+ }
+ src/Stan/NameMeta.hs view
@@ -0,0 +1,182 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Data types and functions for working with meta information.+-}++module Stan.NameMeta+ ( NameMeta (..)++ -- * Pretty show+ , prettyShowNameMeta++ -- * Comparison with 'Name'+ , compareNames+ , hieMatchNameMeta+ , hieFindIdentifier++ -- * Smart constructors+ , baseNameFrom+ , mkBaseListMeta+ , mkBaseOldListMeta+ , mkBaseFoldableMeta++ , unorderedNameFrom+ , textNameFrom++ , ghcPrimNameFrom+ , primTypeMeta+ ) where++import Stan.Core.ModuleName (ModuleName (..), fromGhcModule)+import Stan.Ghc.Compat (Name, isExternalName, moduleUnitId, nameModule, nameOccName, occNameString)+import Stan.Hie.Compat (ContextInfo (IEThing), HieAST (..), IEType (Import), Identifier,+ IdentifierDetails (..), NodeInfo (..), TypeIndex)++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text as T+++-- | Meta information about function/type.+data NameMeta = NameMeta+ { nameMetaPackage :: !Text+ , nameMetaModuleName :: !ModuleName+ , nameMetaName :: !Text+ } deriving stock (Show, Eq)++-- | Pretty show 'NameMeta' in the following format: @package\/module\/name@.+prettyShowNameMeta :: NameMeta -> Text+prettyShowNameMeta NameMeta{..} = T.intercalate "/"+ [ nameMetaPackage+ , unModuleName nameMetaModuleName+ , nameMetaName+ ]++-- | Check if 'NameMeta' is identical to 'Name'.+compareNames :: NameMeta -> Name -> Bool+compareNames NameMeta{..} name =+ let occName = toText $ occNameString $ nameOccName name+ moduleName = fromGhcModule $ nameModule name+ package = show @Text $ moduleUnitId $ nameModule name+ in+ isExternalName name+ && occName == nameMetaName+ && moduleName == nameMetaModuleName+ && ( nameMetaPackage `T.isPrefixOf` package+ -- Cabal hack they made for MacOS. For now, we check for all platforms.+ -- See this issue for more info: https://github.com/kowainik/stan/issues/240+ || withoutVowels nameMetaPackage `T.isPrefixOf` package+ -- Cabal hack they made for Windows. For now, we check for all platforms+ -- See this issue for more info: https://github.com/kowainik/stan/issues/274+ || truncatedWindows nameMetaPackage `T.isPrefixOf` package+ )+ where+ withoutVowels :: Text -> Text+ withoutVowels = T.filter isNotVowel++ isNotVowel :: Char -> Bool+ isNotVowel = \case+ 'a' -> False+ 'e' -> False+ 'i' -> False+ 'o' -> False+ 'u' -> False+ _ -> True++ truncatedWindows :: Text -> Text+ truncatedWindows s = T.take 13 s <> "_"++{- | Check whether HIE 'Identifier' with details is a given 'NameMeta'.+-}+hieMatchNameMeta+ :: NameMeta -- ^ Name meta info+ -> (Identifier, IdentifierDetails TypeIndex) -- ^ HIE identifier+ -> Bool+hieMatchNameMeta nameMeta (identifier, details) = isJust $ do+ -- check: not a module name+ Right name <- Just identifier+ guard+ -- not in the imports+ $ Set.notMember (IEThing Import) (identInfo details)+ -- exact name/module/package+ && compareNames nameMeta name++{- | Check if the given 'HieAST' node is identifier equal to the given+'NameMeta'.+-}+hieFindIdentifier :: NameMeta -> HieAST TypeIndex -> Maybe NameMeta+hieFindIdentifier nameMeta =+ (nameMeta <$)+ . find (hieMatchNameMeta nameMeta)+ . Map.assocs+ . nodeIdentifiers+ . nodeInfo++{- | Create 'NameMeta' for a function from the @base@ package and+a given 'ModuleName'. module.+-}+infix 8 `baseNameFrom`+baseNameFrom :: Text -> ModuleName -> NameMeta+baseNameFrom funName moduleName = NameMeta+ { nameMetaName = funName+ , nameMetaModuleName = moduleName+ , nameMetaPackage = "base"+ }++{- | Create 'NameMeta' for a function from the @base@ package and+the "GHC.List" module.+-}+mkBaseListMeta :: Text -> NameMeta+mkBaseListMeta = (`baseNameFrom` "GHC.List")++{- | Create 'NameMeta' for a function from the @base@ package and+the "Data.OldList" module.+-}+mkBaseOldListMeta :: Text -> NameMeta+mkBaseOldListMeta = (`baseNameFrom` "Data.OldList")++{- | Create 'NameMeta' for a function from the @base@ package and+the "Data.Foldable" module.+-}+mkBaseFoldableMeta :: Text -> NameMeta+mkBaseFoldableMeta = (`baseNameFrom` "Data.Foldable")++{- | Create 'NameMeta' for a function from the @unordered-containers@ package+and a given 'ModuleName' module.+-}+infix 8 `unorderedNameFrom`+unorderedNameFrom :: Text -> ModuleName -> NameMeta+unorderedNameFrom funName moduleName = NameMeta+ { nameMetaName = funName+ , nameMetaModuleName = moduleName+ , nameMetaPackage = "unordered-containers"+ }++{- | Create 'NameMeta' for a function from the @text@ package+and a given 'ModuleName' module.+-}+infix 8 `textNameFrom`+textNameFrom :: Text -> ModuleName -> NameMeta+textNameFrom funName moduleName = NameMeta+ { nameMetaName = funName+ , nameMetaModuleName = moduleName+ , nameMetaPackage = "text"+ }++{- | Create 'NameMeta' for a function from the @ghc-prim@ package+and a given 'ModuleName' module.+-}+infix 8 `ghcPrimNameFrom`+ghcPrimNameFrom :: Text -> ModuleName -> NameMeta+ghcPrimNameFrom funName moduleName = NameMeta+ { nameMetaName = funName+ , nameMetaModuleName = moduleName+ , nameMetaPackage = "ghc-prim"+ }++-- | 'NameMeta' for primitive types.+primTypeMeta :: Text -> NameMeta+primTypeMeta = (`ghcPrimNameFrom` "GHC.Types")
+ src/Stan/Observation.hs view
@@ -0,0 +1,262 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++__Observation__ — a vulnerability found in the target project by @Stan@.+-}++module Stan.Observation+ ( Observation (..)+ , Observations++ -- * Smart constructors+ , mkObservation+ , mkObservationId++ , ignoredObservations++ -- * Pretty print+ , prettyShowObservation+ , prettyShowIgnoredObservations+ , prettyObservationSource+ ) where++import Colourista (blue, bold, formatWith, green, italic, reset, yellow)+import Colourista.Short (b, i)+import Data.List (partition)+import Relude.Unsafe ((!!))+import Slist (Slist)++import Stan.Category (prettyShowCategory)+import Stan.Core.Id (Id (..))+import Stan.Core.ModuleName (ModuleName (..), fromGhcModule)+import Stan.Ghc.Compat (RealSrcSpan, srcSpanEndCol, srcSpanEndLine, srcSpanFile, srcSpanStartCol,+ srcSpanStartLine)+import Stan.Hie.Compat (HieFile (..))+import Stan.Inspection (Inspection (..))+import Stan.Inspection.All (getInspectionById)+import Stan.Report.Settings (ReportSettings (..), Verbosity (..), isHidden)+import Stan.Severity (prettyShowSeverity, severityColour)++import qualified Crypto.Hash.SHA1 as SHA1+import qualified Data.ByteString.Base64 as Base64+import qualified Data.ByteString.Char8 as BS+import qualified Data.HashSet as HS+import qualified Data.List.NonEmpty as NE+import qualified Data.Text as Text+import qualified Slist as S+++{- | Data type to represent discovered by Stan vulnerabilities.+-}+data Observation = Observation+ { observationId :: !(Id Observation)+ , observationInspectionId :: !(Id Inspection)+ , observationLoc :: !RealSrcSpan+ , observationFile :: !FilePath+ , observationModuleName :: !ModuleName+ , observationFileContent :: !ByteString+ } deriving stock (Show, Eq)++-- | Type alias for the sized list of 'Observation's.+type Observations = Slist Observation++-- | Smart constructor for 'Observation's from 'HieFile's.+mkObservation+ :: Id Inspection -- ^ Corresponding 'Inspection's 'Id'.+ -> HieFile+ -> RealSrcSpan -- ^ Position.+ -> Observation+mkObservation insId HieFile{..} srcSpan = Observation+ { observationId = mkObservationId insId moduleName srcSpan+ , observationInspectionId = insId+ , observationLoc = srcSpan+ , observationFile = hie_hs_file+ , observationModuleName = moduleName+ , observationFileContent = hie_hs_src+ }+ where+ moduleName :: ModuleName+ moduleName = fromGhcModule hie_module+++-- | Show 'Observation' in a human-friendly format.+prettyShowObservation :: ReportSettings -> Observation -> Text+prettyShowObservation ReportSettings{..} o@Observation{..} = case reportSettingsVerbosity of+ NonVerbose -> simpleShowObservation+ Verbose -> unlines $ map (" ┃ " <>)+ $ observationTable+ <> ("" : prettyObservationSource True o)+ <> ("" : solution)+ where+ simpleShowObservation :: Text+ simpleShowObservation =+ " ✦ "+ <> b (unId observationId)+ <>" [" <> sev <> "] "+ <> i (showSpan observationLoc)+ <> " — "+ <> inspectionName inspection++ showSpan :: RealSrcSpan -> Text+ showSpan s = show (srcSpanFile s)+ <> "(" <> show (srcSpanStartLine s)+ <> ":" <> show (srcSpanStartCol s)+ <> "-" <> show (srcSpanEndLine s)+ <> ":" <> show (srcSpanEndCol s)+ <> ")"++ observationTable :: [Text]+ observationTable =+ [ element "ID: " <> b (unId observationId)+ , element "Severity: " <> sev+ , element "Inspection ID: " <> unId observationInspectionId+ , element "Name: " <> inspectionName inspection+ , element "Description: " <> inspectionDescription inspection+ , element "Category: " <> categories+ , element "File: " <> toText observationFile+ ]+ where+ element :: Text -> Text+ element = formatWith [italic] . ("✦ " <>)++ sev :: Text+ sev = prettyShowSeverity (inspectionSeverity inspection)++ inspection :: Inspection+ inspection = getInspectionById observationInspectionId++ categories :: Text+ categories = Text.intercalate " "+ $ map prettyShowCategory $ NE.toList $ inspectionCategory inspection++ solution :: [Text]+ solution+ | isHidden reportSettingsSolutionVerbosity || null sols = []+ | otherwise = "💡 " <> formatWith [italic, green] "Possible solution:" :+ map (" ⍟ " <>) sols+ where+ sols = inspectionSolution inspection+++prettyObservationSource+ :: Bool -- ^ Use colouring+ -> Observation+ -> [Text]+prettyObservationSource isColour Observation{..} =+ alignLine (n - 1)+ : map (\x -> alignLine x <> getSourceLine x) [n .. endL]+ ++ [alignLine (endL + 1) <> arrows]+ where+ n, endL :: Int+ n = srcSpanStartLine observationLoc+ endL = srcSpanEndLine observationLoc++ alignLine :: Int -> Text+ alignLine x = Text.justifyRight 4 ' ' (show x) <> " ┃ "++ getSourceLine :: Int -> Text+ getSourceLine x = decodeUtf8 $+ BS.lines observationFileContent !! (x - 1)++ arrows :: Text+ arrows = whenColour isColour (severityColour $ inspectionSeverity $ getInspectionById observationInspectionId)+ <> Text.replicate start " "+ <> Text.replicate arrow "^"+ <> whenColour isColour reset+ where+ start = srcSpanStartCol observationLoc - 1+ arrow = srcSpanEndCol observationLoc - start - 1++{- | Checkes the predicate on colourfulness and returns an empty text when the+colouroing is disabled.+-}+whenColour :: Bool -> Text -> Text+whenColour = memptyIfFalse++{- Returns the list of ignored and unrecognised 'Observation' 'Id's+respectfully.+-}+ignoredObservations+ :: [Id Observation]+ -> Observations+ -> ([Id Observation], [Id Observation])+ -- ^ Ignored ^ Unknown+ignoredObservations ids obs = (ignoredIds, unknownIds)+ where+ obsIds :: HashSet (Id Observation)+ obsIds = fromList $ toList $ S.map observationId obs++ ignoredIds, unknownIds :: [Id Observation]+ (ignoredIds, unknownIds) = partition (`HS.member` obsIds) ids++{- Pretty shows the list of ignored and unrecognised 'Observation' 'Id's+respectfully.++@+Ignored Observation IDs:+ - OBS-STAN-0005-ZKmeC0-125:45+Unrecognised Observation IDs:+ - asd+@+-}+prettyShowIgnoredObservations :: [Id Observation] -> Observations -> Text+prettyShowIgnoredObservations [] _ = ""+prettyShowIgnoredObservations ids obs = ignored <> unknown+ where+ ignored :: Text+ ignored =+ if null ignoredIds+ then ""+ else formatWith [bold, blue] "Ignored Observation IDs:\n"+ <> showIds ignoredIds++ unknown :: Text+ unknown =+ if null unknownIds+ then ""+ else formatWith [bold, yellow] "Unrecognised Observation IDs:\n"+ <> showIds unknownIds++ showIds :: [Id Observation] -> Text+ showIds = unlines . map ((<>) " - " . unId)++ ignoredIds, unknownIds :: [Id Observation]+ (ignoredIds, unknownIds) = ignoredObservations ids obs++{- | Create a stable 'Observation' 'Id' in a such way that:++1. 'Id' doesn't depend on other inspections in this file.+2. 'Id' uniquely identifies 'Observation' location.+3. 'Id's are guaranteed to be the same if the module content didn't+change between different @stan@ runs.++The 'Observation' 'Id' should look like this:++@+OBS-STAN-XXXX-<module-name-hash>-10:42+@+-}+mkObservationId :: Id Inspection -> ModuleName -> RealSrcSpan -> Id Observation+mkObservationId insId moduleName srcSpan = Id $ Text.intercalate "-"+ [ "OBS"+ , unId insId+ , hashModuleName moduleName+ , show (srcSpanStartLine srcSpan) <> ":" <> show (srcSpanStartCol srcSpan)+ ]++{- | Hash module name to a short string of length @6@. Hashing+algorithm is the following:++1. First, run SHA-1.+2. Then, encode with @base64@.+3. Last, take first @6@ characters.+-}+hashModuleName :: ModuleName -> Text+hashModuleName =+ Text.take 6+ . Base64.encodeBase64+ . SHA1.hash+ . encodeUtf8+ . unModuleName
+ src/Stan/Pattern/Ast.hs view
@@ -0,0 +1,295 @@+{-# LANGUAGE CPP #-}++{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Patterns for AST and syntax tree nodes search.+-}++module Stan.Pattern.Ast+ ( -- * Type+ PatternAst (..)+ , Literal (..)++ -- * Helpers+ , namesToPatternAst+ , anyNamesToPatternAst++ -- * eDSL+ , app+ , opApp+ , constructor+ , dataDecl+ , fixity+ , fun+ , guardBranch+ , lazyField+ , range+ , rhs+ , tuple+ , typeSig++ -- * Pattern matching+ , case'+ , lambdaCase+ , patternMatchBranch+ , patternMatchArrow+ , patternMatch_+ , literalPat+ , wildPat++ -- * More low-level interface+ , literalAnns+ ) where++import Stan.Ghc.Compat (FastString)+import Stan.NameMeta (NameMeta (..))+import Stan.Pattern.Edsl (PatternBool (..))+import Stan.Pattern.Type (PatternType)++import qualified Data.Set as Set+++{- | Query pattern used to search AST nodes in HIE AST. This data type+tries to mirror HIE AST to each future matching, so it's quite+low-level, but helper functions are provided.+-}+data PatternAst+ -- | Integer constant in code.+ = PatternAstConstant !Literal+ -- | Name of a specific function, variable or data type.+ | PatternAstName !NameMeta !PatternType+ -- | Variable name.+ | PatternAstVarName !String+ -- | AST node with tags for current node and any children.+ | PatternAstNode+ !(Set (FastString, FastString)) -- ^ Set of context info (pairs of tags)+ -- | AST node with tags for current node and children+ -- patterns. This pattern should match the node exactly.+ | PatternAstNodeExact+ !(Set (FastString, FastString)) -- ^ Set of context info (pairs of tags)+ ![PatternAst] -- ^ Node children+ -- | AST wildcard, matches anything.+ | PatternAstAnything+ -- | Choice between patterns. Should match either of them.+ | PatternAstOr !PatternAst !PatternAst+ -- | Union of patterns. Should match both of them.+ | PatternAstAnd !PatternAst !PatternAst+ -- | Negation of pattern. Should match everything except this pattern.+ | PatternAstNeg !PatternAst+ deriving stock (Show, Eq)++instance PatternBool PatternAst where+ (?) :: PatternAst+ (?) = PatternAstAnything++ neg :: PatternAst -> PatternAst+ neg = PatternAstNeg++ (|||) :: PatternAst -> PatternAst -> PatternAst+ (|||) = PatternAstOr++ (&&&) :: PatternAst -> PatternAst -> PatternAst+ (&&&) = PatternAstAnd++data Literal+ = ExactNum !Int+ | ExactStr !ByteString+ | PrefixStr !ByteString+ | ContainStr !ByteString+ | AnyLiteral+ deriving stock (Show, Eq)++{- | Function that creates 'PatternAst' from the given non-empty list of pairs+'NameMeta' and 'PatternType'.++If the list contains only one 'PatternType' then it is simple 'PatternAstName'.+Else it is 'PatternAstOr' of all such 'PatternAstName's.+-}+namesToPatternAst :: NonEmpty (NameMeta, PatternType) -> PatternAst+namesToPatternAst ((nm, pat) :| []) = PatternAstName nm pat+namesToPatternAst ((nm, pat) :| x:rest) = PatternAstOr+ (PatternAstName nm pat)+ (namesToPatternAst $ x :| rest)++-- | Like 'namesToPatternAst' but doesn't care about types.+anyNamesToPatternAst :: NonEmpty NameMeta -> PatternAst+anyNamesToPatternAst = namesToPatternAst . fmap (, (?))++-- | @app f x@ is a pattern for function application @f x@.+app :: PatternAst -> PatternAst -> PatternAst+app f x = PatternAstNodeExact (one ("HsApp", "HsExpr")) [f, x]++-- | @opApp x op y@ is a pattern for operator application @x `op` y@.+opApp :: PatternAst -> PatternAst -> PatternAst -> PatternAst+opApp x op y = PatternAstNodeExact (one ("OpApp", "HsExpr")) [x, op, y]++-- | @range a b@ is a pattern for @[a .. b]@+range :: PatternAst -> PatternAst -> PatternAst+range from to = PatternAstNodeExact (one ("ArithSeq", "HsExpr")) [from, to]++-- | 'lambdaCase' is a pattern for @\case@ expression (not considering branches).+lambdaCase :: PatternAst+lambdaCase = PatternAstNode (one ("HsLamCase", "HsExpr"))++-- | 'case'' is a pattern for @case EXP of@ expression (not considering branches).+case' :: PatternAst+case' = PatternAstNode (one ("HsCase", "HsExpr"))++-- | Pattern to represent one pattern matching branch.+patternMatchBranch :: PatternAst+patternMatchBranch = PatternAstNode (one ("Match", "Match"))++{- | Pattern for @_@ in pattern matching.++__Note:__ presents on GHC >=8.10 only.+-}+wildPat :: PatternAst+wildPat = PatternAstNode (one ("WildPat", "Pat"))++{- | Pattern for literals in pattern matching.++__Note:__ presents on GHC >=8.10 only.+-}+literalPat :: PatternAst+literalPat = PatternAstNode (one ("NPat", "Pat"))+ ||| PatternAstNode (one ("LitPat", "Pat"))++-- | Pattern to represent one pattern matching branch on @_@.+patternMatch_ :: PatternAst -> PatternAst+patternMatch_ val = PatternAstNodeExact (one ("Match", "Match"))+#if __GLASGOW_HASKELL__ >= 810+ $ wildPat :+#endif+ [patternMatchArrow val]++-- | Pattern to represent right side of the pattern matching, e.g. @-> "foo"@.+patternMatchArrow :: PatternAst -> PatternAst+patternMatchArrow x = PatternAstNodeExact (one ("GRHS", "GRHS")) [x]++{- | Pattern for the top-level fixity declaration:++@+infixr 7 ***, +++, ???+@+-}+fixity :: PatternAst+fixity = PatternAstNode $ one ("FixitySig", "FixitySig")++{- | Pattern for the function type signature declaration:++@+foo :: Some -> Type+@+-}+typeSig :: PatternAst+typeSig = PatternAstNode $ one ("TypeSig", "Sig")++{- | Pattern for the function definition:++@+foo x y = ...+@+-}+fun :: PatternAst+fun = PatternAstNode $ Set.fromList+ [ ("AbsBinds", "HsBindLR")+ , ("FunBind", "HsBindLR")+ , ("Match", "Match")+ ]++{- | @data@ or @newtype@ declaration.+-}+dataDecl :: PatternAst+dataDecl = PatternAstNode $ one ("DataDecl", "TyClDecl")++{- | Constructor of a plain data type or newtype. Children of node+that matches this pattern are constructor fields.+-}+constructor :: PatternAst+constructor = PatternAstNode $ one ("ConDeclH98", "ConDecl")++{- | Lazy data type field. Comes in two shapes:++1. Record field, like: @foo :: Text@+2. Simple type: @Int@+-}+lazyField :: PatternAst+lazyField = lazyRecordField ||| type_++{- | Pattern for any occurrence of a plain type. Covers the following+cases:++* Simple type: Int, Bool, a+* Higher-kinded type: Maybe Int, Either String a+* Type in parenthesis: (Int)+* Tuples: (Int, Bool)+* List type: [Int]+* Function type: Int -> Bool+-}+type_ :: PatternAst+type_ =+ PatternAstNode (one ("HsTyVar", "HsType")) -- simple type: Int, Bool+ |||+ PatternAstNode (one ("HsAppTy", "HsType")) -- composite: Maybe Int+ |||+ PatternAstNode (one ("HsParTy", "HsType")) -- type in ()+ |||+ PatternAstNode (one ("HsTupleTy", "HsType")) -- tuple types: (Int, Bool)+ |||+ PatternAstNode (one ("HsListTy", "HsType")) -- list types: [Int]+ |||+ PatternAstNode (one ("HsFunTy", "HsType")) -- function types: Int -> Bool++{- | Pattern for the field without the explicit bang pattern:++@+someField :: Int+@+-}+lazyRecordField :: PatternAst+lazyRecordField = PatternAstNodeExact+ (one ("ConDeclField", "ConDeclField"))+ [ PatternAstNode+ (fromList+ [ ("AbsBinds", "HsBindLR")+ , ("FunBind", "HsBindLR")+ ]+ )+ , type_+ ]++{- | Pattern for tuples:++* Type signatures: foo :: (Int, Int, Int, Int)+* Literals: (True, 0, [], Nothing)+-}+tuple :: PatternAst+tuple =+ PatternAstNode (one ("HsTupleTy", "HsType")) -- tuple type+ |||+ PatternAstNode (one ("ExplicitTuple", "HsExpr")) -- tuple literal++{- | Pattern for a single @guard@ branch:++@+ | x < y = ...+@+-}+guardBranch :: PatternAst+guardBranch = PatternAstNode $ one ("BodyStmt", "StmtLR")++{- | Pattern for the right-hand-side. Usually an equality sign.++@+ foo = baz+@+-}+rhs :: PatternAst+rhs = PatternAstNode $ one ("GRHS", "GRHS")++-- | Annotations for constants: 0, "foo", etc.+literalAnns :: (FastString, FastString)+literalAnns = ("HsOverLit", "HsExpr")
+ src/Stan/Pattern/Edsl.hs view
@@ -0,0 +1,40 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Embedded DSL for patterns (AST and Type). Implemented using the+/Final Taggless/ approach.+-}++module Stan.Pattern.Edsl+ ( PatternBool (..)+ ) where+++{- | Common interface for 'Bool'-like parts of patterns. Allows to+write composable and reusable complex pattern definitions from smaller+pieces.++Laws (in terms of matching functions that return 'Bool'):++* @'(?)' ≡ 'True'@+* @'neg' '(?)' ≡ 'False'@+* @'(?)' '|||' x ≡ x '|||' '(?)' ≡ 'True'@+* @'(?)' '&&&' x ≡ x '&&&' '(?)' ≡ x@+-}+class PatternBool a where+ -- | Anything. Matching should always return 'True'.+ (?) :: a++ -- | Negation. Inverses the argument.+ neg :: a -> a++ -- | Or-pattern. Choice.+ (|||) :: a -> a -> a++ -- | And-pattern. Both.+ (&&&) :: a -> a -> a++infixr 2 |||+infixr 3 &&&
+ src/Stan/Pattern/Type.hs view
@@ -0,0 +1,182 @@+{- HLINT ignore "Avoid lambda using `infix`" -}++{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Patterns for types and type search.+-}++module Stan.Pattern.Type+ ( -- * Type+ PatternType (..)++ -- * eDSL+ , (|->)+ , (|::)++ -- * Common 'PatternType's+ , listPattern+ , nonEmptyPattern+ , listFunPattern+ , integerPattern+ , naturalPattern++ -- ** Textual types+ , charPattern+ , stringPattern+ , textPattern++ -- * Foldable patterns+ , foldableTypesPatterns+ , foldableMethodsPatterns+ ) where++import Stan.NameMeta (NameMeta (..), baseNameFrom, ghcPrimNameFrom, primTypeMeta, textNameFrom)+import Stan.Pattern.Edsl (PatternBool (..))+++{- | Query pattern used to search types in HIE AST.+-}+data PatternType+ {- | Argument, type or constructor:++ +---------------------+---------------------------------------------------------------------++ | @a@ | @PatternName (NameMeta ... \"a\") []@ |+ +---------------------+---------------------------------------------------------------------++ | @[a]@ | @PatternName (NameMeta ... \"[]\") [aPattern]@ |+ +---------------------+---------------------------------------------------------------------++ | @Either Int String@ | @PatternName (NameMeta ... \"Either\") [intPattern, stringPattern]@ |+ +---------------------+---------------------------------------------------------------------++ -}+ = PatternTypeName !NameMeta ![PatternType]+ -- | Function pattern.+ | PatternTypeFun !PatternType !PatternType+ -- | Type wildcard, matches anything.+ | PatternTypeAnything+ -- | Choice between patterns. Should match either of them.+ | PatternTypeOr !PatternType !PatternType+ -- | Union of patterns. Should match both of them.+ | PatternTypeAnd !PatternType !PatternType+ -- | Negation of pattern. Should match everything except this pattern.+ | PatternTypeNeg !PatternType+ deriving stock (Show, Eq)++instance PatternBool PatternType where+ (?) :: PatternType+ (?) = PatternTypeAnything++ neg :: PatternType -> PatternType+ neg = PatternTypeNeg++ (|||) :: PatternType -> PatternType -> PatternType+ (|||) = PatternTypeOr++ (&&&) :: PatternType -> PatternType -> PatternType+ (&&&) = PatternTypeAnd++-- | Short operator alias for 'PatternFun'.+infixr 4 |->+(|->) :: PatternType -> PatternType -> PatternType+(|->) = PatternTypeFun++-- | Short operator alias for 'PatternTypeName'.+infix 5 |::+(|::) :: NameMeta -> [PatternType] -> PatternType+(|::) = PatternTypeName++-- | 'PatternType' for list @[a]@ or @'String'@.+listPattern :: PatternType+listPattern =+ listNameMeta |:: [ (?) ]+ |||+ "String" `baseNameFrom` "GHC.Base" |:: []+ where+ listNameMeta :: NameMeta+ listNameMeta = primTypeMeta "[]"++-- | 'PatternType' for 'NonEmpty'.+nonEmptyPattern :: PatternType+nonEmptyPattern = "NonEmpty" `baseNameFrom` "GHC.Base" |:: [ (?) ]++-- | 'PatternType' for @[a] -> _@ or @String -> _@.+listFunPattern :: PatternType+listFunPattern = listPattern |-> (?)++-- | 'PatternType' for 'Integer'.+integerPattern :: PatternType+integerPattern = NameMeta+ { nameMetaName = "Integer"+ , nameMetaModuleName = "GHC.Integer.Type"+ , nameMetaPackage = "integer-wired-in"+ } |:: []++-- | 'PatternType' for 'Natural'.+naturalPattern :: PatternType+naturalPattern = "Natural" `baseNameFrom` "GHC.Natural" |:: []++charPattern :: PatternType+charPattern = primTypeMeta "Char" |:: []++-- | 'PatternType' for 'String'.+stringPattern :: PatternType+stringPattern = "String" `baseNameFrom` "GHC.Base" |:: []++-- | 'PatternType' for 'Text'.+textPattern :: PatternType+textPattern = "Text" `textNameFrom` "Data.Text.Internal" |:: []++----------------------------------------------------------------------------+-- Section of Foldable patterns+----------------------------------------------------------------------------++-- | List of types for @STAN-0207@.+foldableTypesPatterns :: NonEmpty PatternType+foldableTypesPatterns = maybePattern :| [eitherPattern, pairPattern]++-- | 'PatternType' for 'Maybe'+maybePattern :: PatternType+maybePattern = "Maybe" `baseNameFrom` "GHC.Maybe" |:: [ (?) ]++-- | 'PatternType' for 'Either'+eitherPattern :: PatternType+eitherPattern = "Either" `baseNameFrom` "Data.Either" |:: [ (?), (?) ]++-- | 'PatternType' for pair @(,)@.+pairPattern :: PatternType+pairPattern = "(,)" `ghcPrimNameFrom` "GHC.Tuple" |:: [ (?), (?) ]++{- | Type patterns for the 'Foldable' typeclass methods. Represented+as a non-empty list of pairs:++* Method name+* Function from type to pattern (where things like 'Maybe', 'Either'+ should be)+-}+foldableMethodsPatterns :: NonEmpty (NameMeta, PatternType -> PatternType)+foldableMethodsPatterns =+ method "fold" `ofType` (\t -> t |-> (?)) :|+ [ method "foldMap" `ofType` \t -> (?) |-> t |-> (?)+ , method "foldMap'" `ofType` \t -> (?) |-> t |-> (?)+ , method "foldr" `ofType` \t -> (?) |-> (?) |-> t |-> (?)+ , method "foldr'" `ofType` \t -> (?) |-> (?) |-> t |-> (?)+ , method "foldl" `ofType` \t -> (?) |-> (?) |-> t |-> (?)+ , method "foldl'" `ofType` \t -> (?) |-> (?) |-> t |-> (?)+ , method "foldr1" `ofType` \t -> (?) |-> t |-> (?)+ , method "foldl1" `ofType` \t -> (?) |-> t |-> (?)+ , method "toList" `ofType` \t -> t |-> (?)+ , method "null" `ofType` \t -> t |-> (?)+ , method "length" `ofType` \t -> t |-> (?)+ , method "elem" `ofType` \t -> (?) |-> t |-> (?)+ , method "maximum" `ofType` \t -> t |-> (?)+ , method "minimum" `ofType` \t -> t |-> (?)+ , method "sum" `ofType` \t -> t |-> (?)+ , method "product" `ofType` \t -> t |-> (?)+ ]+ where+ ofType :: a -> b -> (a, b)+ ofType = (,)++ method :: Text -> NameMeta+ method name = name `baseNameFrom` "Data.Foldable"
+ src/Stan/Report.hs view
@@ -0,0 +1,29 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Report and report settings types.+-}++module Stan.Report+ ( generateReport+ ) where++import Text.Blaze.Html.Renderer.Utf8 (renderHtml)++import Stan.Analysis (Analysis)+import Stan.Config (Config)+import Stan.Info (ProjectInfo, StanEnv)+import Stan.Report.Html (stanHtml)+++generateReport+ :: Analysis+ -> Config+ -> [Text] -- ^ Warnings during Trial config selections+ -> StanEnv -- ^ Environment information+ -> ProjectInfo -- ^ Project related Information+ -> IO ()+generateReport an c ws env = writeFileLBS "stan.html" . renderHtml .+ stanHtml an c ws env
+ src/Stan/Report/Css.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE PostfixOperators #-}++{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Css to be used in the generated HTML in the report.+-}+module Stan.Report.Css+ ( stanCss+ ) where++import Prelude hiding (div, rem, (&), (**))++import Clay hiding (brown, cols, grid)++import qualified Clay.Media as M+import qualified Data.List.NonEmpty as NE+++stanCss :: Css+stanCss = do+ grid+ main_ ? marginAuto+ nav ? do+ backgroundColor darkGrey+ color yellow+ padding2 (1%) (0%)+ -- ".nav-item" |> a ? do+ a ? do+ textDecoration none+ color yellow+ "@href" & do+ textDecoration underline+ ":hover" & fontWeight bold++ footer <> header ? do+ display block+ textAlign center+ width (100%)+ maxWidth (100%)+ backgroundColor lightGrey+ borderTop solid (px 15) darkGrey+ footer ? marginTop (2%)+ footer |> ".container" ? marginTopBottom (px 20)+ ".footer-link" ** (a # hover) ? (fontWeight normal >> textDecoration none)+ ".ins-link" ? do+ important (textDecoration none)+ padding2 (px 2) (px 10)+ backgroundColor darkGrey+ color white+ ".ins-link" # hover ? (color darkGrey >> backgroundColor transparent)+ pre <> code ? (backgroundColor brown >> color white >> padding (px 1) 2 1 2)+ pre ? do+ margin2 (2%) (10%)+ paddingAll 2+ overflowX auto+ ".solutions" ? do+ margin2 (1%) (10%)+ paddingAll 1+ backgroundColor (rgba 255 246 143 0.4)+ important $ borderRadius (px 4) 4 4 4+ (".solutions" <> ".config-warnings") ** ul ? listStyleType none+ ".solutions" ** (li # before) ? content (stringContent "💡")+ ".config-warnings" ** (li # before) ? content (stringContent "⚙️")+ table ? do+ width (100%) -- >> tableLayout fixed)+ important $ borderRadius (px 4) 4 4 4+ borderCollapse collapse+ th # firstChild ? borderRadius (px 4) 0 0 0+ th # lastChild ? borderRadius 0 (px 4) 0 0++ td <> th ? padding2 nil (px 8)+ (".observation" <> "#configurations" <> "#stan-info" <> "#severity") ** (tr <> td <> th) ?+ border solid (px 1) lightGrey+ ".border-shadow" ? do+ boxShadow $ one $ bsColor (setA 0.3 darkGrey) $ shadowWithSpread (px 0) 0 4 4+ borderStyle (other $ Value $ Plain "hidden")++ ".info-name" ? fontStyle italic+ ".info-data" ? fontWeight bold++ "#stan-info" ** table ? marginAuto+ blockquote ? do+ paddingLeft (2%)+ borderLeft solid (px 4) darkGrey+ boxShadow $ one $ bsColor lightGrey $ shadow (px (-4)) 0++ ".obs-li" ? important (marginAll 0)+ "#file" |> h3 ? paddingLeft (px 5)+ "#file" |> ul ? listStyleType none++ stanCategory+ stanSeverity+ summarySection+ collapsible++stanCategory :: Css+stanCategory = do+ ".cats" ? (listStyleType none >> overflow hidden >> paddingAll 0)+ ".inline" ? display inline+ ".cats" |> li ? float floatLeft+ td |> ".cats" |> li ? marginTopBottom (px 2)+ ".cat" ? do+ backgroundColor pink+ borderRadius (px 3) (px 0) (px 0) (px 3)+ display inlineBlock+ padding (px 0) (px 20) (px 0) (px 23)+ textDecoration none+ position relative+ transitionProperty "color"+ transitionDuration (sec 0.2)+ ".cat" # before ? do+ backgroundColor white+ borderRadius (px 10) 10 10 10+ boxShadow $ one $ bsInset $ bsColor (rgba 0 0 0 0.25) $+ shadow (px 0) (px 1)+ content (stringContent "")+ height (px 6)+ left (px 10)+ position absolute+ width (px 6)+ top (px 10)+ catTriangle ".cat" veryLightGrey+ (".inline" |> ".cat") # after ? backgroundColor white+ where+ catTriangle cl c = cl # after ? do+ backgroundColor c+ borderBottom solid (px 13) transparent+ borderLeft solid (px 10) pink+ borderTop solid (px 13) transparent+ content (stringContent "")+ position absolute+ right (0%) >> top (0%)++stanSeverity :: Css+stanSeverity = do+ ".severity" ? do+ display inlineBlock+ padding (px 1) 0 0 0+ border solid (px 1) darkGrey+ borderRadius (px 4) (px 4) (px 4) (px 4)+ lineHeight (unitless 1)+ ".severityText" ? padding2 (px 0) (px 15)+ ".severityStyle" ? severityCss cyan+ ".severityPerformance" ? severityCss blue+ ".severityPotentialBug" ? severityCss magenta+ ".severityWarning" ? severityCss yellow+ ".severityError" ? severityCss red++ ".remove" ? configActionsCss red+ ".include" ? configActionsCss green+ ".exclude" ? configActionsCss yellow+ ".ignore" ? configActionsCss orange+ where+ configActionsCss :: Color -> Css+ configActionsCss c = color black >> backgroundColor (setA 0.5 c)++ severityCss :: Color -> Css+ severityCss c = do+ padding2 (px 0) (px 15)+ height (100%)+ backgroundColor c+ backgroundClip $ boxClip paddingBox+ borderRadius (px 4) (px 0) (px 0) (px 4)+ borderRight solid (px 1) darkGrey++collapsible :: Css+collapsible = do+ ".collapsible" ? do+ width (100%)+ fontSize (rem 1.125)+ important (marginLeft (0%) >> marginBottom (0%) >> marginRight (0%))+ backgroundColor darkGrey+ color white+ cursor pointer+ textAlign (alignSide sideLeft)++ ".active" <> (".collapsible" # hover) ? backgroundColor lightGrey++ ".collapsible" # after ? do+ content (stringContent "\\002B")+ color white+ fontWeight bold+ float floatRight+ marginLeft (px 5)++ ".active" # after ? content (stringContent "\\2212")++ ".content" ? do+ maxHeight nil+ overflow hidden+ transitionProperty "max-height"+ transitionTimingFunction easeOut+ transitionDuration (sec 0.2)+ backgroundColor veryLightGrey+ ".content" |> div ?+ padding 0 0 0 (px 18)++summarySection :: Css+summarySection = do+ ".sum" ?+ (display block >> clear both >> position relative)+ ".sum" # before ? do+ content (stringContent "")+ width (rem 4) >> height (rem 4)+ float floatLeft+ margin 0 (rem 1.5) (rem 0.75) 0+ backgroundImage $ linearGradient (other $ Value $ Plain "to bottom right")+ [ (color1, 25)+ , (color2, 100)+ ]+ textShadow 0 0 (px 2) color1;+ borderRadius (50%) 50 50 50+ display inlineFlex+ alignItems center+ justifyContent center+ "shape-outside" -: "ellipse()"+ zIndex 1++ ".sum" # after ? do+ width (rem 2) >> height (rem 2)+ position absolute+ top (px 0) >> left (px 0)+ content (stringContent "")+ backgroundColor color1+ zIndex (-1)+ borderTopLeftRadius (px 3) (px 3)+ where+ color1, color2 :: Color+ color1 = darkGrey+ color2 = veryLightGrey++grid :: Css+grid = do+ (html <> body) ? do+ height (100%)+ width (100%)+ marginAll 0+ paddingAll 0+ left (0%)+ top (0%)+ fontFamily [] [sansSerif]+ fontSize (100%)+ color darkGrey+ lineHeight (unitless 1.5)+ h1 ? fontSize (rem 2.5)+ h2 ? fontSize (rem 2)+ h3 ? fontSize (rem 1.375)+ h4 ? fontSize (rem 1.125)+ h5 ? fontSize (rem 1)+ h6 ? fontSize (rem 0.875)+ p ? (fontSize (rem 1.125) >> fontWeight (weight 200) >> lineHeight (unitless 1.8))+ ".centre" ? (textAlign center >> marginAuto)+ ".container" ? (width (90%) >> marginAuto)+ ".row" ? (position relative >> width (100%))+ ".row [class^='col']" ? do+ float floatLeft+ margin2 (rem 0.5) (2%)+ minHeight (rem 0.125)+ sconcat colClasses ? width (96%)+ colsGrid colClassesSm+ ".row" # after ? do+ content (stringContent "")+ display displayTable+ clear both+ ".hidden-sm" ? display displayNone+ mediaQuery 33.75 $ ".container" ? width (80%)+ mediaQuery 45 $ colsGrid colClasses+ mediaQuery 60 $ ".container" ? (width (75%) >> maxWidth (rem 60))++ ".grey-bg" ? (backgroundColor darkGrey >> color white)+ ".very-light-bg" ? backgroundColor veryLightGrey+ where+ cols :: NonEmpty Text+ cols = fmap ((".col-" <>) . show) $ (1 :: Int) :| [2..12]++ colClasses, colClassesSm :: NonEmpty Selector+ colClasses = fmap element cols+ colClassesSm = fmap (element . (<> "-sm")) cols++ colsGrid :: NonEmpty Selector -> Css+ colsGrid classes = sequence_ $ NE.zipWith (\cl per -> cl ? width (per %)) classes w++ w :: NonEmpty Rational+ w = 4.33 :| [12.66, 21, 29.33, 37.66, 46, 54.33, 62.66, 71, 79.33, 87.66, 96]++ mediaQuery :: Double -> Css -> Css+ mediaQuery x = query M.screen [M.minWidth (em x)]++marginAuto :: Css+marginAuto = marginLeft auto >> marginRight auto++marginAll :: Size Percentage -> Css+marginAll x = margin x x x x++margin2 :: Size a -> Size b -> Css+margin2 x y = marginTopBottom x >> marginLeftRight y++marginTopBottom :: Size a -> Css+marginTopBottom x = marginTop x >> marginBottom x++marginLeftRight :: Size a -> Css+marginLeftRight x = marginLeft x >> marginRight x++paddingAll :: Size Percentage -> Css+paddingAll x = padding x x x x++padding2 :: Size a -> Size a -> Css+padding2 x y = padding x y x y++(%) :: Rational -> Size Percentage+(%) = fromRational++lightGrey, darkGrey, veryLightGrey, brown :: Color+lightGrey = rgb 189 189 189+darkGrey = rgb 97 97 97+veryLightGrey = rgb 241 241 241+brown = rgb 78 52 46
+ src/Stan/Report/Html.hs view
@@ -0,0 +1,453 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++HTML to be generated in the report.+-}++module Stan.Report.Html+ ( stanHtml+ ) where++import Prelude hiding (div, head)+import Relude.Extra.Enum (universe)++import Clay (compact, renderWith)+import Text.Blaze.Html+import Text.Blaze.Html5 hiding (ins, map, summary)++import Stan.Analysis (Analysis (..))+import Stan.Analysis.Pretty (AnalysisNumbers (..), ProjectHealth (..), analysisToNumbers,+ prettyHealth, toProjectHealth)+import Stan.Analysis.Summary (Summary (..), createSummary)+import Stan.Category (Category (..))+import Stan.Config (Config, ConfigP (..))+import Stan.Config.Pretty (ConfigAction, configActionClass, configToTriples, prettyConfigAction)+import Stan.Core.Id (Id (..))+import Stan.Core.ModuleName (ModuleName (..))+import Stan.FileInfo (FileInfo (..), extensionsToText)+import Stan.Info (ProjectInfo (..), StanEnv (..), StanSystem (..), StanVersion (..), stanSystem,+ stanVersion)+import Stan.Inspection (Inspection (..))+import Stan.Inspection.All (getInspectionById, inspectionsMap)+import Stan.Observation (Observation (..), ignoredObservations, prettyObservationSource)+import Stan.Report.Css (stanCss)+import Stan.Severity (Severity (..), severityDescription)++import qualified Data.HashMap.Strict as HM+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import qualified Slist as S+import qualified Text.Blaze.Html5.Attributes as A+++stanHtml :: Analysis -> Config -> [Text] -> StanEnv -> ProjectInfo -> Html+stanHtml an config warnings env project =+ docTypeHtml (stanHead >> stanBody)+ where+ stanBody :: Html+ stanBody = body $ do+ stanHeader+ stanMain an config warnings env project+ stanFooter+ stanJs++stanHeader :: Html+stanHeader = header ! A.class_ "centre" $ do+ divClass "row" (h1 "Stan Report")+ nav ! A.class_ "row" $ do+ navItem "General Info"+ navItem "Observations"+ navItem "Configurations"+ navItem "Report Explained"+ where+ navItem :: Text -> Html+ navItem h = divClass "col-3 nav-item"+ (a ! A.href (fromText $ "#" <> hToId h) $ toHtml h)++stanMain :: Analysis -> Config -> [Text] -> StanEnv -> ProjectInfo -> Html+stanMain an config warnings env project = main ! A.class_ "container" $ do+ divClass "row" stanIntro+ divIdClassH "Stan Info" "row" (stanInfo env)+ divIdClass "general-info" "row" $ do+ divIdClassH "Project Info" "col-6" (stanProject project)+ divIdClassH "Analysis Info" "col-6" (stanAnalysis analysisNumbers)+ divIdClassH "Static Analysis Summary" "row" (stanSummary an analysisNumbers)+ -- divIdClassH "Graphs" "row" (p_ "Maybe later")+ divIdClassH "Observations" "row" (stanObservations an)+ divIdClassH "Configurations" "row" (stanConfig an config warnings)+ -- divIdClassH "Summary" "row" (p_ "Later")+ divIdClassH "Report Explained" "" $ do+ divIdClassH "Inspections" "row" $ stanInspections (analysisInspections an)+ divIdClassH "Severity" "row" stanSeverityExplained+ where+ analysisNumbers :: AnalysisNumbers+ analysisNumbers = analysisToNumbers an++stanIntro :: Html+stanIntro = p $ do+ toHtml @Text "This is the Haskell Static Analysis report generated by "+ a ! A.href "https://kowainik.github.io/projects/stan" ! A.class_ "ins-link" $+ toHtml @Text "Stan"++stanInfo :: StanEnv -> Html+stanInfo StanEnv{..} = do+ let StanVersion{..} = stanVersion+ let StanSystem{..} = stanSystem+ divClass "row" $ blockP $ fold+ [ "In this section, you can find the general information about the used "+ , "Stan tool, compile-time and run-time environment "+ , "variables and settings, including build information, system data and "+ , "execution configurations."+ ]+ divClass "col-10" $+ table ! (A.class_ "border-shadow" <> A.style "table-layout:fixed") $ do+ colgroup (col ! A.style "width:25%" >> col)+ tr2 "Stan Version"+ tableRow "Version" svVersion+ tableRow "Git Revision" svGitRevision+ tableRow "Release Date" svCommitDate+ tr2 "System Info"+ tableRow "Operating System" ssOs+ tableRow "Architecture" ssArch+ tableRow "Compiler" ssCompiler+ tableRow "Compiler Version" ssCompilerVersion+ tr2 "Environment"+ tableRow "Environment Variables" seEnvVars+ tableRow "TOML configuration files" (traverse_ toHtml seTomlFiles)+ tableRow "CLI arguments" (List.unwords seCliArgs)+ where+ tr2 x = tr $ td ! (A.colspan "2" <> A.class_ "centre grey-bg") $ strong x++stanProject :: ProjectInfo -> Html+stanProject ProjectInfo{..} = do+ divClass "row" (blockP "Information about the analysed project")+ tableWithShadow "" $ do+ colgroup (col ! A.class_ "info-name" >> col ! A.class_ "info-data")+ tableRow "Project name" piName+ tableRow "Cabal Files" (List.unwords piCabalFiles)+ tableRow "HIE Files Directory" piHieDir+ tableRow "Files Number" piFileNumber++stanAnalysis :: AnalysisNumbers -> Html+stanAnalysis AnalysisNumbers{..} = do+ divClass "row" (blockP "Summary stats from the static analysis")+ tableWithShadow "" $ do+ tableRow "Modules" anModules+ tableRow "LoC" anLoc+ tableRow "Extensions" anExts+ tableRow "SafeHaskel Extensions" anSafeExts+ tableRow "Available inspections" (HM.size inspectionsMap)+ tableRow "Checked inspections" anIns+ tableRow "Found Observations" anFoundObs+ tableRow "Ignored Observations" anIgnoredObs++stanSummary :: Analysis -> AnalysisNumbers -> Html+stanSummary analysis AnalysisNumbers{..} = do+ divClass "row" (blockP "Here you can find the overall conclusion based on the various metadata and gathered information during the work of Stan on this project.")+ ul ! A.class_ "col-10" $ do+ liSum $ do+ h4 (toHtml $ "Project health: " <> prettyHealth anHealth)+ span $ toHtml @Text $ fold+ [ "This number was calculated based on the total number of used inspections "+ , "and the number of triggered inspections in the project. The calculated number "+ , "also defines the overall project health status."+ ]+ liSum $ do+ h4 (toHtml $ "The project " <> showProjectHealth projectHealth)+ span $ toHtml $ showHealthConclusions projectHealth+ summary+ where+ projectHealth :: ProjectHealth+ projectHealth = toProjectHealth anHealth++ showProjectHealth :: ProjectHealth -> Text+ showProjectHealth = \case+ Unhealthy -> "is unhealthy"+ LowHealth -> "has low health"+ MediumHealth -> "has medium health"+ Healthy -> "is healthy"++ showHealthConclusions :: ProjectHealth -> Text+ showHealthConclusions = fold . \case+ Unhealthy ->+ [ "According to the Stan analysis, the project has a lot of vulnerabilities. "+ , "But this also means that there is a room for improving code quality! "+ , "Don't give up and continue doing great work!"+ ]+ LowHealth ->+ [ "According to the Stan analysis, the project has issues of a different variety. But you can improve that! "+ , "Stan provides solutions to the observed problems to help you improve the code quality."+ ]+ MediumHealth ->+ [ "Stan discovered several potential issues in the project. "+ , "Nice job, the overall project quality is good. And you can easily make it even better!"+ ]+ Healthy ->+ [ "Excellent work! Stan haven't found any vulnerabilities in the code."+ ]++ summary :: Html+ summary = case createSummary analysis of+ Nothing -> liSum $ do+ h4 "Congratulations! Your project has zero vulnerabilities!"+ span "Stan carefully run all configured inspection and found 0 observations and vulnerabilities to the project."+ Just Summary{..} -> do+ liSum $ do+ h4 $ toHtml ("Watch out for " <> unId summaryInspectionId)+ span $ do+ toHtml @Text "By the result of Stan analysis, the most common inspection for this project is "+ inspectionLink summaryInspectionId+ liSum $ do+ h4 $ toHtml ("Vulnerable module: " <> unModuleName summaryModule)+ span $ do+ toHtml @Text "The "+ code (toHtml $ unModuleName summaryModule)+ toHtml @Text " module is the most vulnerable one in the project, as it got the most number of observations"+ liSum $ do+ h4 (toHtml $ "Popular category: " <> unCategory summaryCategory)+ categories "inline" $ one summaryCategory+ toHtml @Text "The project has the most problems with inspections from this category"+ liSum $ do+ h4 $ toHtml ("Severity: " <> show @Text summarySeverity)+ toHtml @Text "The highest severity of found vulnerabilities is "+ severity (show @Text summarySeverity)++ liSum :: Html -> Html+ liSum = li ! A.class_ "sum"++stanObservations :: Analysis -> Html+stanObservations Analysis{..} = do+ divClass "row" $ blockP $ fold+ [ "Based on the analysis results, Stan found different vulnerabilities "+ , "distributed among the analysed files. In Stan terminology, we call such "+ , "vulnerability as Observation. Below you can see the more detailed "+ , "information about each observation, and find the possible ways to fix "+ , "them for your project."+ ]+ traverse_ stanPerFile $+ filter (not . null . fileInfoObservations) $ Map.elems analysisFileMap++stanPerFile :: FileInfo -> Html+stanPerFile FileInfo{..} = divIdClass "file" "row" $ do+ h3 ! A.class_ "grey-bg" $ toHtml $ "📄 " <> fileInfoPath+ ul $ do+ li $ tableWithShadow "col-6" $ do+ tableRow "Module" $ code $ toHtml $ unModuleName fileInfoModuleName+ tableRow "Lines of Code" fileInfoLoc+ li $ divClass "extensions" $ do+ stanExtensions ".cabal" (extensionsToText fileInfoCabalExtensions)+ stanExtensions "module" (extensionsToText fileInfoExtensions)+ li ! A.class_ "col-12 obs-li" $ divClass "observations col-12" $ do+ h4 "Observations"+ traverse_ stanObservation $ S.sortOn observationLoc fileInfoObservations++stanExtensions :: Text -> [Text] -> Html+stanExtensions from exts = divClass "col-6" $ do+ button ! A.class_ "collapsible" $ toHtml $ "Extensions from " <> from+ ol ! A.class_ "content" $ traverse_ (li . toHtml) exts++inspectionLink :: Id Inspection -> Html+inspectionLink ins = a ! A.class_ "ins-link" ! A.href (fromText $ "#" <> insId) $ toHtml insId+ where+ insId :: Text+ insId = unId ins++stanObservation :: Observation -> Html+stanObservation o@Observation{..} = divIdClass (unId observationId) "observation row" $ do+ general+ pre $ toHtml (unlines $ prettyObservationSource False o)+ solutionsDiv inspection+ where+ general = divClass "observation-general" $ tableWithShadow "" $ do+ tableR "ID" (unId observationId)+ tableR "Severity" (severityFromIns inspection)+ tableR "Description" (inspectionDescription inspection)+ tableR "Inspection ID" (inspectionLink observationInspectionId)+ tableR "Category" (categories "inline" $ inspectionCategory inspection)+ tableR "File" observationFile++ tableR :: ToMarkup a => Text -> a -> Html+ tableR name val = tr $ do+ td ! A.class_ "info-name very-light-bg" $ toHtml name+ td ! A.class_ "info-data" $ toHtml val++ inspection :: Inspection+ inspection = getInspectionById observationInspectionId++severityFromIns :: Inspection -> Html+severityFromIns ins = severity $ show @Text $ inspectionSeverity ins++severity :: Text -> Html+severity severityTxt = span ! A.class_ "severity" $ do+ span ! A.class_ (fromText $ "severity" <> severityTxt) $ toHtml @Text ""+ span ! A.class_ "severityText" $ toHtml severityTxt++categories :: Text -> NonEmpty Category -> Html+categories cl cats = ul ! A.class_ (fromText $ "cats " <> cl)+ $ traverse_ ((li ! A.class_ "cat") . toHtml . unCategory)+ $ toList cats++solutionsDiv :: Inspection -> Html+solutionsDiv ins = memptyIfTrue (null solutions) $ divClass "solutions border-shadow" $ do+ h4 "Possible solutions"+ uList solutions+ where+ solutions :: [Text]+ solutions = inspectionSolution ins++stanInspections :: HashSet (Id Inspection) -> Html+stanInspections ins = do+ divClass "row" (blockP "List of Inspections used for analysing the project")+ div $ traverse_ stanInspection $ sortWith unId $ toList ins++stanInspection :: Id Inspection -> Html+stanInspection (getInspectionById -> ins@Inspection{..}) = do+ button ! A.class_ "collapsible" ! A.id (fromText insId) $+ toHtml ("Explore Inspection " <> insId)+ divClass "content row" $ divIdClass (insId <> "-content") "inspection col-12" $ do+ h3 $ toHtml ("Inspection " <> insId)+ p $ strong $ toHtml inspectionName+ p $ em $ toHtml inspectionDescription+ div (severityFromIns ins)+ div (categories "" inspectionCategory)+ solutionsDiv ins+ where+ insId :: Text+ insId = unId inspectionId++stanConfig :: Analysis -> Config -> [Text] -> Html+stanConfig Analysis{..} config warnings = divClass "col-12" $ do+ divClass "row" $ blockP $ fold+ [ "This section describes the final Stan configuration that was used on "+ , "the project and explains how this result was assembled. Stan runtime "+ , "settings have many parts, and each of them can come from different "+ , "configuration sources. Stan is using Environment variables, TOML "+ , "configuration file and CLI arguments to get the final results. If some "+ , "option is specified through the multiple sources, the most prioritized "+ , "one is used. "+ ]+ divClass "row" $ table $ do+ tr (th "Action" >> th "Filter" >> th "Scope")+ traverse_ toRows (configToTriples config)+ divClass "ignored-observations row" $ do+ toUl ignoredIds "Ignored Observations"+ "These observations are flagged as ignored through the configurations and are not considered in the final report"+ toUl unknownIds "Unrecognised Observations"+ "Some observation IDs specified in the configurations are not found"+ divClass "config-warnings row" $ do+ h4 "Configuration Process Information"+ p $+ "Information and warnings that were gathered during the configuration assemble process. "+ <> "This helps to understand how different parts of the configurations were retrieved."+ uList warnings+ where+ toRows :: (ConfigAction, Text, Text) -> Html+ toRows (act, fil, sc) = tr !+ A.class_ (fromText $ configActionClass act) $ do+ td ! A.class_ "centre" $ span $ strong $ toHtml $ prettyConfigAction act+ td $ toHtml fil+ td $ toHtml sc++ toUl :: [Id a] -> Text -> Text -> Html+ toUl ids headerTxt desc = memptyIfTrue (null ids) $ divClass "ignored-obs" $ do+ h4 $ toHtml headerTxt+ p $ toHtml desc+ uList $ map unId ids++ ignoredIds, unknownIds :: [Id Observation]+ (ignoredIds, unknownIds) = ignoredObservations+ (configIgnored config)+ analysisIgnoredObservations++stanSeverityExplained :: Html+stanSeverityExplained = do+ divClass "col-5" $+ blockP "We are using the following severity system to indicate the observation level"++ tableWithShadow "col-7" $ do+ tr ! greyBg $ (th "Severity" >> th "Description")+ traverse_ toSeverityRow (universe @Severity)+ where+ toSeverityRow :: Severity -> Html+ toSeverityRow s = tr $ do+ td (severity $ show s)+ td (toHtml $ severityDescription s)++stanFooter :: Html+stanFooter = footer $ do+ divClass "container" $ do+ divClass "row footer-link" $ do+ span "This report was generated by "+ a ! A.href "https://github.com/kowainik/stan" $+ toHtml @Text "Stan — Haskell Static Analysis Tool."+ divClass "row footer-link" $ do+ span "Stan is created and maintained by "+ a ! A.href "https://kowainik.github.io" $ toHtml @Text "Kowainik"+ nav ! A.class_ "row centre" $ h3 $ strong "© Kowainik 2020"++stanHead :: Html+stanHead = head $ do+ meta ! (A.httpEquiv "Content-Type" <> A.content "text/html; charset=UTF-8")+ meta ! (A.httpEquiv "X-UA-Compatible" <> A.content "IE=Edge")+ nameContent "viewport" "width=device-width, initial-scale=1.0"+ nameContent "description" "Stan Report"+ nameContent "keywords" "Haskell, Static Analysis"+ nameContent "author" "Kowainik"+ title "Stan Report"++ style (toHtml $ renderWith compact [] stanCss)+ where+ nameContent x y = meta ! (A.name x <> A.content y)++stanJs :: Html+stanJs = script $ toHtml $ List.unlines+ [ "var coll = document.getElementsByClassName(\"collapsible\");"+ , "var i;"+ , ""+ , "for (i = 0; i < coll.length; i++) {"+ , " coll[i].addEventListener(\"click\", function() {"+ , " this.classList.toggle(\"active\");"+ , " var content = this.nextElementSibling;"+ , " if (content.style.maxHeight){"+ , " content.style.maxHeight = null;"+ , " } else {"+ , " content.style.maxHeight = content.scrollHeight + \"px\";"+ , " }"+ , " });"+ , "}"+ ]++divClass :: Text -> Html -> Html+divClass c = div ! A.class_ (fromText c)++divIdClass :: Text -> Text -> Html -> Html+divIdClass aId c = div ! (A.id (fromText aId) <> A.class_ (fromText c))++divIdClassH :: Text -> Text -> Html -> Html+divIdClassH h c rest = divIdClass (hToId h) c (h2 (toHtml h) >> rest)++blockP :: Text -> Html+blockP = blockquote . p . toHtml++tableRow :: ToMarkup a => Text -> a -> Html+tableRow name val = tr $ do+ td ! A.class_ "info-name" $ toHtml name+ td ! A.class_ "info-data very-light-bg" $ toHtml val++tableWithShadow :: Text -> Html -> Html+tableWithShadow cl = table ! A.class_ (fromText $ "border-shadow " <> cl)++uList :: ToMarkup a => [a] -> Html+uList = ul . traverse_ (li . toHtml)++greyBg :: Attribute+greyBg = A.class_ "grey-bg"++hToId :: Text -> Text+hToId = T.intercalate "-" . map T.toLower . words++fromText :: IsString s => Text -> s+fromText = fromString . toString
+ src/Stan/Report/Settings.hs view
@@ -0,0 +1,47 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Report settings types.+-}++module Stan.Report.Settings+ ( ReportSettings (..)++ -- * Verbosity+ , Verbosity (..)+ , isVerbose+ -- * Toggle+ , ToggleSolution (..)+ , isHidden+ ) where+++{- | Settings for produced report.+-}+data ReportSettings = ReportSettings+ { reportSettingsVerbosity :: !Verbosity+ , reportSettingsSolutionVerbosity :: !ToggleSolution+ }++data Verbosity+ = Verbose+ | NonVerbose+ deriving stock (Show)++isVerbose :: Verbosity -> Bool+isVerbose = \case+ Verbose -> True+ NonVerbose -> False++-- | Boolean for showing/hiding solution information of observations.+data ToggleSolution+ = HideSolution+ | ShowSolution+ deriving stock (Show)++-- | Is the toggle option set to 'HideSolution'?+isHidden :: ToggleSolution -> Bool+isHidden HideSolution = True+isHidden ShowSolution = False
+ src/Stan/Severity.hs view
@@ -0,0 +1,72 @@+{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++This module introduces 'Severity' data type for expressing how severe the+message is. Also, it contains useful functions to work with 'Severity'.+-}++module Stan.Severity+ ( Severity (..)++ -- * Pretty printing+ , severityDescription+ , severityColour+ , prettyShowSeverity+ ) where++import Colourista (blue, bold, cyan, formatWith, magenta, red, yellow)+++{- | Severity level of the inspection.++ +---------------+-----------------------------------------------------++ | Severity | Example |+ +===============+=====================================================++ | 'Style' | Missing @infix@, or type signature in @where@ |+ +---------------+-----------------------------------------------------++ | 'Performance' | Usage of 'Data.Foldable.sum', 'Data.Foldable.foldl' |+ +---------------+-----------------------------------------------------++ | 'PotentialBug'| Some common user errors: @[0 .. length xs]@ |+ +---------------+-----------------------------------------------------++ | 'Warning' | Partial functions, like 'GHC.List.head' |+ +---------------+-----------------------------------------------------++ | 'Error' | Usage of 'undefined' in code |+ +---------------+-----------------------------------------------------+++-}+data Severity+ -- | Code style issues. Usually harmless.+ = Style+ -- | Serious defects that could cause slowness and space leaking.+ | Performance+ -- | Human errors in code.+ | PotentialBug+ -- | Potential runtime errors on some inputs.+ | Warning+ -- | Dangerous behaviour.+ | Error+ deriving stock (Show, Read, Eq, Ord, Enum, Bounded)++-- | Description of each 'Severity' level.+severityDescription :: Severity -> Text+severityDescription = \case+ Style -> "Code style issues. Usually harmless."+ Performance -> "Serious defects that could cause slowness and space leaking."+ PotentialBug -> "Human errors in code."+ Warning -> "Potential runtime errors on some inputs."+ Error -> "Dangerous behaviour."++-- | Get the colour of the severity level.+severityColour :: Severity -> Text+severityColour = \case+ Style -> cyan+ Performance -> blue+ PotentialBug -> magenta+ Warning -> yellow+ Error -> red++-- | Show 'Severity' in a human-friendly format.+prettyShowSeverity :: Severity -> Text+prettyShowSeverity s = formatWith [severityColour s, bold] $ show s
+ src/Stan/Toml.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE ApplicativeDo #-}++{- |+Copyright: (c) 2020 Kowainik+SPDX-License-Identifier: MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++@tomland@ library integration. 'TomlCodec's for the 'Config' data type.+-}++module Stan.Toml+ ( getTomlConfig+ -- * Codecs+ , configCodec+ -- * Files+ , usedTomlFiles+ ) where++import Colourista (infoMessage)+import System.Directory (doesFileExist, getCurrentDirectory, getHomeDirectory)+import System.FilePath ((</>))+import Toml (AnyValue, BiMap (..), Key, TomlBiMap, TomlCodec, (.=))+import Trial (TaggedTrial, Trial (..), fiasco)+import Trial.Tomland (taggedTrialListCodec)++import Stan.Category (Category (..))+import Stan.Config (Check (..), CheckFilter (..), CheckType (..), ConfigP (..), PartialConfig,+ Scope (..))+import Stan.Core.Id (Id (..))+import Stan.Inspection (Inspection (..))+import Stan.Observation (Observation (..))+import Stan.Severity (Severity (..))++import qualified Toml+++{- | Based on the incoming settings returns the TOML configuration files that+were used to get the final config.+-}+usedTomlFiles :: Bool -> Maybe FilePath -> IO [FilePath]+usedTomlFiles useDefault mFile = do+ def <-+ if useDefault+ then do+ cur <- defaultCurConfigFile+ ifM (doesFileExist cur) (pure [cur]) $ do+ home <- defaultHomeConfigFile+ memptyIfNotExist home+ else pure []+ custom <- case mFile of+ Nothing -> pure []+ Just f -> memptyIfNotExist f+ pure $ def <> custom+ where+ memptyIfNotExist :: FilePath -> IO [FilePath]+ memptyIfNotExist fp = ifM (doesFileExist fp) (pure [fp]) (pure [])++getTomlConfig :: Bool -> Maybe FilePath -> IO PartialConfig+getTomlConfig useDefault mTomlFile = do+ def <-+ if useDefault+ then defaultCurConfigFile >>= readToml >>= \case+ Result _ r -> pure r+ resCur -> defaultHomeConfigFile >>= readToml >>= \ resHome ->+ pure $ inline $ resCur <> resHome+ else let e = fiasco "Selected NOT to use any default .stan.toml configuration files"+ in pure $ ConfigP e e e+ case mTomlFile of+ Just tomlFile -> (def <>) . inline <$> readToml tomlFile+ Nothing -> pure def+ where+ readToml :: FilePath -> IO (Trial Text PartialConfig)+ readToml file = do+ isFile <- doesFileExist file+ if isFile+ then do+ infoMessage $ "Reading Configurations from " <> toText file <> " ..."+ pure <$> Toml.decodeFile configCodec file+ else pure $ fiasco $ "TOML Configurations file doesn't exist: " <> toText file++ inline :: Trial Text PartialConfig -> PartialConfig+ inline = \case+ Fiasco f -> let e = Fiasco f in ConfigP e e e+ Result _ res -> res++defaultTomlFile :: FilePath+defaultTomlFile = ".stan.toml"++defaultHomeConfigFile :: IO FilePath+defaultHomeConfigFile = (</> defaultTomlFile) <$> getHomeDirectory++defaultCurConfigFile :: IO FilePath+defaultCurConfigFile = (</> defaultTomlFile) <$> getCurrentDirectory++configCodec :: TomlCodec PartialConfig+configCodec = ConfigP+ <$> checksCodec .= configChecks+ <*> removedCodec .= configRemoved+ <*> ignoredCodec .= configIgnored++removedCodec :: TomlCodec (TaggedTrial Text [Scope])+removedCodec = taggedTrialListCodec "remove" scopeCodec++ignoredCodec :: TomlCodec (TaggedTrial Text [Id Observation])+ignoredCodec = taggedTrialListCodec "ignore" idCodec++checksCodec :: TomlCodec (TaggedTrial Text [Check])+checksCodec = taggedTrialListCodec "check" checkCodec++checkCodec :: TomlCodec Check+checkCodec = Check+ <$> checkTypeCodec .= checkType+ <*> checkFilterCodec .= checkFilter+ <*> scopeCodec .= checkScope++checkTypeCodec :: TomlCodec CheckType+checkTypeCodec = Toml.enumBounded "type"++----------------------------------------------------------------------------+-- CheckFilter+----------------------------------------------------------------------------++checkInspection :: CheckFilter -> Maybe (Id Inspection)+checkInspection = \case+ CheckInspection idI -> Just idI+ _other -> Nothing++checkSeverity :: CheckFilter -> Maybe Severity+checkSeverity = \case+ CheckSeverity sev -> Just sev+ _other -> Nothing++checkCategory :: CheckFilter -> Maybe Category+checkCategory = \case+ CheckCategory category -> Just category+ _other -> Nothing++checkAll :: CheckFilter -> Maybe ()+checkAll = \case+ CheckAll -> Just ()+ _other -> Nothing++checkFilterCodec :: TomlCodec CheckFilter+checkFilterCodec =+ Toml.dimatch checkInspection CheckInspection idCodec+ <|> Toml.dimatch checkSeverity CheckSeverity (Toml.enumBounded "severity")+ <|> Toml.dimatch checkCategory CheckCategory (Toml.diwrap (Toml.text "category"))+ <|> Toml.dimatch checkAll (const CheckAll) (allCodec "filter")++idCodec :: TomlCodec (Id a)+idCodec = Toml.diwrap $ Toml.text "id"++----------------------------------------------------------------------------+-- CheckScope+----------------------------------------------------------------------------++scopeFile :: Scope -> Maybe FilePath+scopeFile = \case+ ScopeFile filePath -> Just filePath+ _other -> Nothing++scopeDir :: Scope -> Maybe FilePath+scopeDir = \case+ ScopeDirectory dir -> Just dir+ _other -> Nothing++scopeAll :: Scope -> Maybe ()+scopeAll = \case+ ScopeAll -> Just ()+ _other -> Nothing++scopeCodec :: TomlCodec Scope+scopeCodec =+ Toml.dimatch scopeFile ScopeFile (Toml.string "file")+ <|> Toml.dimatch scopeDir ScopeDirectory (Toml.string "directory")+ <|> Toml.dimatch scopeAll (const ScopeAll) (allCodec "scope")++----------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------++-- | Helper 'BiMap' for the hardcoded string @"all"@.+_All :: TomlBiMap () AnyValue+_All = _AllText >>> Toml._Text+ where+ _AllText :: TomlBiMap () Text+ _AllText = BiMap+ { forward = \() -> Right "all"+ , backward = \case+ "all" -> Right ()+ t -> Left $ Toml.ArbitraryError $ "Expected Text value \"all\" but got: " <> t+ }++allCodec :: Key -> TomlCodec ()+allCodec = Toml.match _All
+ stan.cabal view
@@ -0,0 +1,207 @@+cabal-version: 2.4+name: stan+version: 0.0.0.0+synopsis: Haskell STatic ANalyser+description:+ Stan is a Haskell __ST__atic __AN__alysis CLI tool.+ See [README.md](https://github.com/kowainik/stan#stan) for more details.+homepage: https://github.com/kowainik/stan+bug-reports: https://github.com/kowainik/stan/issues+license: MPL-2.0+license-file: LICENSE+author: Veronika Romashkina, Dmitrii Kovanikov+maintainer: Kowainik <xrom.xkov@gmail.com>+copyright: 2020 Kowainik+category: Static Analysis+build-type: Simple+stability: experimental+extra-doc-files: README.md+ CHANGELOG.md+tested-with: GHC == 8.8.3+ GHC == 8.10.1++source-repository head+ type: git+ location: https://github.com/kowainik/stan.git++common common-options+ build-depends: base >= 4.13 && < 4.15++ ghc-options: -Wall+ -Wcompat+ -Widentities+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ if impl(ghc >= 8.0)+ ghc-options: -Wredundant-constraints+ if impl(ghc >= 8.2)+ ghc-options: -fhide-source-paths+ if impl(ghc >= 8.4)+ ghc-options: -Wmissing-export-lists+ -Wpartial-fields+ if impl(ghc >= 8.8)+ ghc-options: -Wmissing-deriving-strategies+ -Werror=missing-deriving-strategies+ -fwrite-ide-info+ -hiedir=.hie+ if impl(ghc >= 8.10)+ ghc-options: -Wunused-packages++ default-language: Haskell2010+ default-extensions: ConstraintKinds+ DeriveGeneric+ DerivingStrategies+ GeneralizedNewtypeDeriving+ InstanceSigs+ KindSignatures+ LambdaCase+ OverloadedStrings+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeApplications+ ViewPatterns++common common-relude+ build-depends: relude ^>= 0.7.0.0+ mixins: base hiding (Prelude)+ , relude (Relude as Prelude+ , Relude.Extra.Enum+ , Relude.Extra.Lens+ , Relude.Extra.Map+ , Relude.Extra.Tuple+ , Relude.Unsafe+ )++library+ import: common-options+ , common-relude+ hs-source-dirs: src+ exposed-modules: Stan+ Stan.Analysis+ Stan.Analysis.Analyser+ Stan.Analysis.Pretty+ Stan.Analysis.Summary+ Stan.Cabal+ Stan.Category+ Stan.Cli+ Stan.Config+ Stan.Config.Pretty+ Stan.Core.Id+ Stan.Core.List+ Stan.Core.ModuleName+ Stan.Example+ Stan.Ghc.Compat+ Stan.EnvVars+ Stan.FileInfo+ Stan.Hie+ Stan.Hie.Compat+ Stan.Hie.Debug+ Stan.Hie.MatchAst+ Stan.Hie.MatchType+ Stan.Info+ Stan.Inspection+ Stan.Inspection.All+ Stan.Inspection.AntiPattern+ Stan.Inspection.Infinite+ Stan.Inspection.Partial+ Stan.Inspection.Style+ Stan.NameMeta+ Stan.Observation+ Stan.Pattern.Ast+ Stan.Pattern.Edsl+ Stan.Pattern.Type+ Stan.Report+ Stan.Report.Css+ Stan.Report.Html+ Stan.Report.Settings+ Stan.Severity+ Stan.Toml++ autogen-modules: Paths_stan+ other-modules: Paths_stan++ build-depends: array ^>= 0.5+ , base64 ^>= 0.4.1+ , blaze-html ^>= 0.9.1+ , bytestring ^>= 0.10+ , clay ^>= 0.13+ , colourista ^>= 0.1.0.0+ , containers ^>= 0.6+ , cryptohash-sha1 ^>= 0.11+ , dir-traverse ^>= 0.2.2.2+ , directory ^>= 1.3+ , extensions ^>= 0.0.0.1+ , filepath ^>= 1.4+ , ghc >= 8.8 && < 8.11+ , ghc-boot-th >= 8.8 && < 8.11+ , gitrev ^>= 1.3.1+ , optparse-applicative ^>= 0.15+ , pretty-simple ^>= 3.2+ , slist ^>= 0.1+ , text ^>= 1.2+ , tomland ^>= 1.3.0.0+ , trial ^>= 0.0.0.0+ , trial-optparse-applicative ^>= 0.0.0.0+ , trial-tomland ^>= 0.0.0.0+ , unordered-containers ^>= 0.2++executable stan+ import: common-options+ hs-source-dirs: app+ main-is: Main.hs+ build-depends: stan++library target+ import: common-options+ hs-source-dirs: target+ build-depends: bytestring+ , filepath+ , text+ , unordered-containers+ exposed-modules: Target.AntiPattern+ Target.AntiPattern.Stan0206+ Target.AntiPattern.Stan0206Extensions+ Target.AntiPattern.Stan0212+ Target.AntiPattern.Stan0213+ Target.AntiPattern.Stan0214+ Target.Infinite+ Target.Partial+ Target.Style++test-suite stan-test+ import: common-options+ , common-relude+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Test.Stan.Analysis+ Test.Stan.Analysis.AntiPattern+ Test.Stan.Analysis.Common+ Test.Stan.Analysis.Infinite+ Test.Stan.Analysis.Partial+ Test.Stan.Analysis.Style+ Test.Stan.Cli+ Test.Stan.Config+ Test.Stan.Gen+ Test.Stan.Number+ Test.Stan.Observation+ Test.Stan.Toml++ build-depends: stan+ , containers+ , filepath ^>= 1.4+ , ghc+ , hedgehog ^>= 1.0+ , hspec ^>= 2.7+ , hspec-hedgehog ^>= 0.0.1.2+ , optparse-applicative+ , text+ , tomland+ , trial+ , unordered-containers++ ghc-options: -threaded+ -rtsopts+ -with-rtsopts=-N
+ target/Target/AntiPattern.hs view
@@ -0,0 +1,94 @@+{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}++module Target.AntiPattern where++import Data.Foldable (forM_, for_)+import System.FilePath ((</>))++import qualified Data.ByteString.Char8 as BS8+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.List as List+import qualified Data.Text as Text+++stanLengthXs :: [a] -> [Int]+stanLengthXs xs = [0 .. length xs]++stanLengthXsMinus1 :: [a] -> [Int]+stanLengthXsMinus1 xs = [0 .. length xs - 1]++stanFoldl :: Foldable t => (b -> a -> b) -> b -> t a -> b+stanFoldl = foldl++stanPack8 :: String -> BS8.ByteString+stanPack8 = BS8.pack++stanHashMapSize :: HM.HashMap Int Int -> Int+stanHashMapSize = HM.size++stanHashMapLength :: HM.HashMap Int Int -> Int+stanHashMapLength = length++stanHashSetSize :: HS.HashSet Int -> Int+stanHashSetSize = HS.size++stanHashSetLength :: HS.HashSet Int -> Int+stanHashSetLength = length++stanTupleLength :: Int+stanTupleLength = length ((1, 2) :: (Int, Int))++stanMaybeNull :: Maybe Int -> Bool+stanMaybeNull = null++stanEitherFoldr :: Either Int Int -> Int+stanEitherFoldr = foldr (+) 0++stanTextLength :: Text.Text -> Int+stanTextLength = Text.length++stanNub :: [Int] -> [Int]+stanNub = List.nub++stanFor_ :: IO ()+stanFor_ = for_ [1 :: Int .. 1000] print++stanForM_ :: Int -> IO ()+stanForM_ n = forM_ [1 .. n] print++stanUrl1 :: FilePath+stanUrl1 = "http://google.com" </> "asd"++stanUrl2 :: FilePath+stanUrl2 = fooUrl </> "asd"+ where+ fooUrl :: FilePath+ fooUrl = "asd"++stanUrl3 :: FilePath+stanUrl3 = "asd" </> fooUrl+ where+ fooUrl :: FilePath+ fooUrl = "asd"++stanUrl4 :: FilePath+stanUrl4 = fooUral </> "asd"+ where+ fooUral :: FilePath+ fooUral = "asd"++stanSlashesUnix :: FilePath+stanSlashesUnix = "asd/asd" </> "xxx"++stanSlashesWindows :: FilePath+stanSlashesWindows = "asd\\asd" </> "xxx"++stanSlashesUnix' :: FilePath+stanSlashesUnix' = "xxx" </> "asd/asd"++stanSlashesWindows' :: FilePath+stanSlashesWindows' = "xxx" </> "asd\\asd"++stanSlashesNo :: FilePath+stanSlashesNo = "xxx" </> "asd"
+ target/Target/AntiPattern/Stan0206.hs view
@@ -0,0 +1,22 @@+{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}++module Target.AntiPattern.Stan0206 where+++data RecordExample a = RecordExample+ { strictField :: !Int+ , lazyField :: Int+ , lazyVar :: a+ }++newtype NewtypeExample1 = NewtypeExample1 Bool+newtype NewtypeExample2 = NewtypeExample2+ { unWrap :: Int+ }++data PlainExample+ = Mk1+ !Int+ Int+ | Mk2 !Int+ | Mk3 Bool
+ target/Target/AntiPattern/Stan0206Extensions.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}++{-# LANGUAGE StrictData #-}++module Target.AntiPattern.Stan0206Extensions where+++data Record a = Record+ { field1 :: Int+ , field2 :: ~a+ }++data User = User Int String
+ target/Target/AntiPattern/Stan0212.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}++module Target.AntiPattern.Stan0212 where++import System.IO.Unsafe (unsafeDupablePerformIO, unsafeFixIO, unsafeInterleaveIO, unsafePerformIO)+import Unsafe.Coerce (unsafeCoerce)+++stanUndefined :: a+stanUndefined = undefined++stanUnsafeCoerce :: String -> Int+stanUnsafeCoerce = unsafeCoerce++stanUnsafePerformIO :: String+stanUnsafePerformIO = unsafePerformIO getLine++stanUnsafeInterleaveIO :: IO ()+stanUnsafeInterleaveIO = unsafeInterleaveIO (pure ())++stanUnsafeDupablePerformIO :: String+stanUnsafeDupablePerformIO = unsafeDupablePerformIO getLine++stanUnsafeFixIO :: IO ()+stanUnsafeFixIO = unsafeFixIO pure
+ target/Target/AntiPattern/Stan0213.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}++{- | Sum types pattern matching on @_@ -}++module Target.AntiPattern.Stan0213 where++++stanLambda :: Ordering -> String+stanLambda = \case+ EQ -> "EQ"+ _ -> "Other"++stanLambdaLit :: Int -> String+stanLambdaLit = \case+ 1 -> "One"+ _ -> "Other"++stanCase :: Ordering -> String+stanCase o = case o of+ EQ -> "EQ"+ LT -> "LT"+ _ -> "Other"++stanCaseLit :: String -> String+stanCaseLit str = case 'x' : str of+ "xAbc" -> "Here"+ "xBcc" -> "There"+ _ -> "Far far away"++stanCaseNo :: Ordering -> String+stanCaseNo o = case o of+ EQ -> "EQ"+ LT -> "LT"+ GT -> "GT"++stanLambdaNo :: Ordering -> String+stanLambdaNo = \case+ EQ -> "EQ"+ LT -> "LT"+ GT -> "GT"++stanMaybeCase :: Int -> Maybe Int -> Int+stanMaybeCase i mb = case mb of+ Just x -> x + 1+ _ -> i + 1++stanMaybeLambdaCase :: Int -> Maybe Int -> Int+stanMaybeLambdaCase i = \case+ Just x -> x + 1+ _ -> i + 1++stanMaybeLambdaCaseNo :: Int -> Maybe Int -> Int+stanMaybeLambdaCaseNo i = \case+ Just x -> x + 1+ Nothing -> i + 1++stanMaybeLambdaCaseFirst_ :: Int -> Maybe Int -> Int+stanMaybeLambdaCaseFirst_ i = \case+ _ -> i + 1++stanLambdaLitChar :: Char -> String+stanLambdaLitChar = \case+ 'c' -> "One"+ _ -> "Other"
+ target/Target/AntiPattern/Stan0214.hs view
@@ -0,0 +1,44 @@+{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}++module Target.AntiPattern.Stan0214 where+++isEq :: Int -> Int -> Bool+isEq x y+ | x < y = False+ | x > y = False+ | otherwise = True++isEq2 :: String -> String -> Bool+isEq2 s1 s2+ | s1 == s2 = True+ | s1 < s2 = False+ | otherwise = True++weirdEq :: Int -> Int -> Bool+weirdEq a b+ | a == b = True+ | a - 1 == b + 1 = True -- almost equal+ | otherwise = False++geqOrEq :: Int -> Int -> Bool+geqOrEq a b+ | a >= b = True+ | otherwise = False++inRange :: Int -> Bool+inRange i+ | i >= 100 = False+ | i >= 80 = True+ | i >= 60 = False+ | i >= 40 = True+ | otherwise = False++data Tree a = Leaf | Node a (Tree a) (Tree a)++insert :: Ord a => a -> Tree a -> Tree a+insert x Leaf = Node x Leaf Leaf+insert x node@(Node y l r)+ | x < y = Node y (insert x l) r+ | x > y = Node y l (insert x r)+ | otherwise = node
+ target/Target/Infinite.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}++module Target.Infinite where++import Data.List (genericLength, isSuffixOf)++import qualified GHC.List+++stanReverse :: [a] -> [a]+stanReverse = reverse++stanIsSuffixOf :: String -> Bool+stanIsSuffixOf = isSuffixOf "stan"++stanLength :: String -> Int+stanLength = length++stanGenericLength :: String -> Int+stanGenericLength = genericLength++stanSum :: Num a => [a] -> a+stanSum = sum++stanProduct :: Num a => [a] -> a+stanProduct = product++stanGhcListxxLength :: [a] -> Int+stanGhcListxxLength = GHC.List.length
+ target/Target/Partial.hs view
@@ -0,0 +1,90 @@+{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}++module Target.Partial where++import Data.Foldable (maximumBy, minimumBy)+import Data.List (foldl1', genericIndex)+import Data.List.NonEmpty (NonEmpty)+import Data.Maybe (fromJust)+import GHC.Exts (fromList)+import Numeric.Natural (Natural)++import qualified Data.List.NonEmpty as NE+++stanHead :: [a] -> a+stanHead = head++stanTail :: [a] -> [a]+stanTail = tail++stanInit :: [a] -> [a]+stanInit = init++stanLast :: [a] -> a+stanLast = last++stanAt :: [a] -> a+stanAt xs = xs !! 42++stanCycle :: [a] -> [a]+stanCycle = cycle++stanGenericIndex :: [a] -> Int -> a+stanGenericIndex = genericIndex++stanFromJust :: Maybe Int -> Int+stanFromJust = fromJust++stanRead :: String -> Int+stanRead = read++stanSucc :: Int -> Int+stanSucc = succ++stanPred :: Natural -> Natural+stanPred = pred++stanToEnum :: Int -> Bool+stanToEnum = toEnum++stanMaximum :: [Int] -> Int+stanMaximum = maximum++stanMinimum :: Ord a => [a] -> a+stanMinimum = minimum++stanMaximumBy :: [Int] -> Int+stanMaximumBy = maximumBy compare++stanMinimumBy :: (a -> a -> Ordering) -> [a] -> a+stanMinimumBy = minimumBy++stanFoldl1 :: (a -> a -> a) -> [a] -> a+stanFoldl1 = foldl1++stanFoldl1' :: (a -> a -> a) -> [a] -> a+stanFoldl1' = foldl1'++stanFoldr1 :: (a -> a -> a) -> [a] -> a+stanFoldr1 = foldr1++stanFromList :: [x] -> NonEmpty x+stanFromList = fromList++stanFromInteger :: Integer -> Natural+stanFromInteger = fromInteger++-- Other tests++stanSuccNatural :: Natural -> Natural+stanSuccNatural = succ -- no warning here++stanPredInteger :: Integer -> Integer+stanPredInteger = pred -- no warning here++stanPredPoly :: Enum a => a -> a+stanPredPoly = pred++stanFromListNE :: [x] -> NonEmpty x+stanFromListNE = NE.fromList
+ target/Target/Style.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}++module Target.Style where+++(???) :: Int -> Int -> Int+(???) = (+)++infixl 7 ***+(***) :: Int -> Int -> Int+(***) = (*)++quad :: Int -> (Int, Int, Int, Int)+quad x = (x, x, x, x)++triple :: Int -> (Int, Int, Int)+triple y = (y, y, y)++data TupleRecord = TupleRecord+ { quadruple :: (Int, Int, Int, Int)+ }
+ test/Spec.hs view
@@ -0,0 +1,36 @@+module Main (main) where++import HieTypes (HieFile (..))+import System.FilePath ((</>))+import Test.Hspec (hspec)++import Stan.Hie (readHieFiles)+import Test.Stan.Analysis (analysisSpec)+import Test.Stan.Cli (cliSpec)+import Test.Stan.Config (configSpec)+import Test.Stan.Number (linesOfCodeSpec, modulesNumSpec)+import Test.Stan.Observation (observationSpec)+import Test.Stan.Toml (tomlSpec)+++main :: IO ()+main = do+ hieFiles <- readHieFiles ".hie"+ case filter isTargetFile hieFiles of+ [] -> do+ putStrLn "FAILED: target/ files are not found"+ exitFailure+ testHies -> do+ Just exampleHie <- pure $+ find ((==) ("target" </> "Target" </> "Partial.hs") . hie_hs_file) testHies+ hspec $ do+ linesOfCodeSpec exampleHie+ modulesNumSpec $ length hieFiles+ cliSpec+ tomlSpec+ configSpec+ observationSpec+ analysisSpec testHies++isTargetFile :: HieFile -> Bool+isTargetFile HieFile{..} = "target" `isPrefixOf` hie_hs_file
+ test/Test/Stan/Analysis.hs view
@@ -0,0 +1,68 @@+module Test.Stan.Analysis+ ( analysisSpec+ ) where++import HieTypes (HieFile (..))+import System.FilePath ((</>))+import Test.Hspec (Spec, describe, it, runIO, shouldBe)++import Stan (createCabalExtensionsMap)+import Stan.Analysis (Analysis (..), runAnalysis)+import Stan.Config (mkDefaultChecks)+import Stan.Core.Id (Id (..))+import Stan.Observation (Observation (..))+import Test.Stan.Analysis.AntiPattern (analysisAntiPatternSpec)+import Test.Stan.Analysis.Infinite (analysisInfiniteSpec)+import Test.Stan.Analysis.Partial (analysisPartialSpec)+import Test.Stan.Analysis.Style (analysisStyleSpec)++import qualified Data.Set as Set+++analysisSpec :: [HieFile] -> Spec+analysisSpec hieFiles = describe "Static Analysis" $ do+ extensionsMap <- runIO $ createCabalExtensionsMap ["stan.cabal"] hieFiles+ let checksMap = mkDefaultChecks (map hie_hs_file hieFiles)++ -- tests without ignorance+ let analysis = runAnalysis extensionsMap checksMap [] hieFiles+ analysisPartialSpec analysis+ analysisInfiniteSpec analysis+ analysisAntiPatternSpec analysis+ analysisStyleSpec analysis+ analysisExtensionsSpec analysis++ -- testing with ignoring observations+ let analyseWithIgnored ignoredObs = runAnalysis+ extensionsMap+ checksMap+ ignoredObs+ -- running analysis on a single file to speed up tests+ [hieFileByName $ "target" </> "Target" </> "Partial.hs"]+ analysisIgnoredObservationsSpec analyseWithIgnored+ where+ hieFileByName :: FilePath -> HieFile+ hieFileByName path = case filter ((== path) . hie_hs_file) hieFiles of+ [] -> error $ "Invalid test file path: " <> toText path+ h:_ -> h++analysisExtensionsSpec :: Analysis -> Spec+analysisExtensionsSpec Analysis{..} = describe "Used extensions" $ do+ it "should correctly count total amount of used extensions" $+ Set.size (fst analysisUsedExtensions) `shouldBe` 15+ it "should correctly count total amount of used safe extensions" $+ Set.size (snd analysisUsedExtensions) `shouldBe` 0++analysisIgnoredObservationsSpec+ :: ([Id Observation] -> Analysis) -- ^ Run analysis with ignored observations+ -> Spec+analysisIgnoredObservationsSpec analyse = describe "Ignores observations" $ do+ let obsId = Id "OBS-STAN-0001-pnvTKA-16:12"++ it "ObservationId is present when not ignored " $ do+ let observationsIds = fmap observationId $ analysisObservations $ analyse []+ find (== obsId) observationsIds `shouldBe` Just obsId++ it "ObservationId is properly ignored " $ do+ let observations = analysisObservations $ analyse [obsId]+ find ((== obsId) . observationId) observations `shouldBe` Nothing
+ test/Test/Stan/Analysis/AntiPattern.hs view
@@ -0,0 +1,196 @@+module Test.Stan.Analysis.AntiPattern+ ( analysisAntiPatternSpec+ ) where++import Test.Hspec (Spec, describe, it, xit)++import Stan.Analysis (Analysis)+import Test.Stan.Analysis.Common (noObservationAssert, observationAssert, observationAssertMulti)++import qualified Stan.Inspection.AntiPattern as AntiPattern+++analysisAntiPatternSpec :: Analysis -> Spec+analysisAntiPatternSpec analysis = describe "Anti-patterns" $ do+ let checkObservation = observationAssert ["AntiPattern"] analysis+ let noObservation = noObservationAssert ["AntiPattern"] analysis++ it "STAN-0201: finds usage of '[0 .. length xs]'" $+ checkObservation AntiPattern.stan0201 16 19 35+ it "STAN-0201: doesn't trigger on '[0 .. length xs - 1]'" $+ noObservation AntiPattern.stan0201 19+ it "STAN-0202: finds usage of 'foldl'" $+ checkObservation AntiPattern.stan0202 22 13 18+ it "STAN-0203: finds usage of 'Data.ByteString.Char8.pack'" $+ checkObservation AntiPattern.stan0203 25 13 21+ it "STAN-0204: finds usage of 'Data.HashMap.size'" $+ checkObservation AntiPattern.stan0204 28 19 26+ it "STAN-0204: finds usage of 'length' for 'HashMap'" $+ checkObservation AntiPattern.stan0204 31 21 27+ it "STAN-0205: finds usage of 'Data.HashSet.size'" $+ checkObservation AntiPattern.stan0205 34 19 26+ it "STAN-0205: finds usage of 'length' for 'HashSet'" $+ checkObservation AntiPattern.stan0205 37 21 27++ strictFieldsSpec analysis++ it "STAN-0207: 'length' for (,)" $+ checkObservation AntiPattern.stan0207 40 19 25+ it "STAN-0207: 'null' for Maybe" $+ checkObservation AntiPattern.stan0207 43 17 21+ it "STAN-0207: 'foldr' for Either" $+ checkObservation AntiPattern.stan0207 46 19 24++ it "STAN-0208: finds usage of 'length' for 'Text'" $+ checkObservation AntiPattern.stan0208 49 18 29+ it "STAN-0209: finds usage of 'nub' for lists" $+ checkObservation AntiPattern.stan0209 52 11 19+ it "STAN-0210: finds usage of 'for_' for ranges" $+ checkObservation AntiPattern.stan0210 55 12 35+ it "STAN-0210: finds usage of 'forM_' for ranges" $+ checkObservation AntiPattern.stan0210 58 15 29++ it "STAN-0211: finds usage of 'http://' '</>'" $+ checkObservation AntiPattern.stan0211 61 12 41+ it "STAN-0211: finds usage of 'fooUrl' '</>'" $+ checkObservation AntiPattern.stan0211 64 12 28+ it "STAN-0211: finds usage of '</>' 'fooUrl'" $+ checkObservation AntiPattern.stan0211 70 12 28+ it "STAN-0211: doesn't trigger on 'fooUral' '</>'" $+ noObservation AntiPattern.stan0211 76++ unsafeFunctionsSpec analysis+ patternMatchSpec analysis+ compareSpec analysis++ it "STAN-0215: finds usage of '/' in '</>' path left" $+ checkObservation AntiPattern.stan0215 82 19 38+ it "STAN-0215: finds usage of '/' in '</>' path right" $+ checkObservation AntiPattern.stan0215 88 20 39+ it "STAN-0215: finds usage of '\\' in '</>' path left" $+ checkObservation AntiPattern.stan0215 85 22 42+ it "STAN-0215: finds usage of '\\' in '</>' path right" $+ checkObservation AntiPattern.stan0215 91 23 43+ it "STAN-0215: don't triggered when no slashes" $+ noObservation AntiPattern.stan0215 94++strictFieldsSpec :: Analysis -> Spec+strictFieldsSpec analysis = describe "STAN-0206: Strict data type fields" $ do+ describe "Without extensions" $ do+ let checkObservation = observationAssert ["AntiPattern", "Stan0206"] analysis+ let noObservation = noObservationAssert ["AntiPattern", "Stan0206"] analysis++ it "Doesn't trigger on strict field" $+ noObservation AntiPattern.stan0206 7+ it "Finds simple lazy field" $+ checkObservation AntiPattern.stan0206 8 7 25+ it "Finds polymorphic lazy field" $+ checkObservation AntiPattern.stan0206 9 7 23+ it "Doesn't trigger on plain newtype" $+ noObservation AntiPattern.stan0206 12+ it "Doesn't trigger on a record newtype" $+ noObservation AntiPattern.stan0206 14+ it "Doesn't trigger on strict sum type field among many fields" $+ noObservation AntiPattern.stan0206 19+ it "Finds lazy field in a sum type constructor with multiple fields" $+ checkObservation AntiPattern.stan0206 20 9 12+ it "Doesn't trigger on a single strict sum type field" $+ noObservation AntiPattern.stan0206 21+ it "Finds single lazy field in a sum type with multiple constructors" $+ checkObservation AntiPattern.stan0206 22 11 15++ describe "With the 'StrictData' extension" $ do+ let noObservation = noObservationAssert ["AntiPattern", "Stan0206Extensions"] analysis++ it "Doesn't trigger on a simple record field" $+ noObservation AntiPattern.stan0206 9+ it "Doesn't trigger on explicitly lazy field" $+ noObservation AntiPattern.stan0206 10+ it "Doesn't trigger on plain data type" $+ noObservation AntiPattern.stan0206 13++unsafeFunctionsSpec :: Analysis -> Spec+unsafeFunctionsSpec analysis = describe "STAN-0212: Unsafe functions" $ do+ let checkObservation = observationAssert ["AntiPattern", "Stan0212"] analysis++ it "Find: undefined" $+ checkObservation AntiPattern.stan0212 10 17 26+ it "Find: unsafeCoerce" $+ checkObservation AntiPattern.stan0212 13 20 32+ it "Find: unsafePerformIO" $+ checkObservation AntiPattern.stan0212 16 23 38+ it "Find: unsafeInterleaveIO" $+ checkObservation AntiPattern.stan0212 19 26 44+ it "Find: unsafeDupablePerformIO" $+ checkObservation AntiPattern.stan0212 22 30 52+ it "Find: unsafeFixIO" $+ checkObservation AntiPattern.stan0212 25 19 30++patternMatchSpec :: Analysis -> Spec+patternMatchSpec analysis = describe "STAN-0212: Pattern Matching on _" $ do+ let checkObservation = observationAssert ["AntiPattern", "Stan0213"] analysis+ let noObservation = noObservationAssert ["AntiPattern", "Stan0213"] analysis++ it "for lambda case" $+ checkObservation AntiPattern.stan0213 12 5 17+ it "not triggered for lambda case on integers" $+ noObservation AntiPattern.stan0213 17+ it "for case" $+ checkObservation AntiPattern.stan0213 23 5 18+ it "not triggered for case on strings" $+ noObservation AntiPattern.stan0213 29+ it "not triggered for case on all constructors" $ do+ noObservation AntiPattern.stan0213 33+ noObservation AntiPattern.stan0213 34+ noObservation AntiPattern.stan0213 35++ it "not triggered for lambda case on all constructors" $ do+ noObservation AntiPattern.stan0213 39+ noObservation AntiPattern.stan0213 40+ noObservation AntiPattern.stan0213 41++ it "for case on maybe" $+ checkObservation AntiPattern.stan0213 46 5 20+ it "for lambda case on maybe" $+ checkObservation AntiPattern.stan0213 51 5 20+ it "not triggered for lambda case on maybe with full pm" $+ noObservation AntiPattern.stan0213 56+ it "not triggered for lambda case on one branch _" $+ noObservation AntiPattern.stan0213 60++ it "not triggered for lambda case on Chars" $+ noObservation AntiPattern.stan0213 65++compareSpec :: Analysis -> Spec+compareSpec analysis = describe "STAN-0214: Replace multiple comparison operators" $ do+ let checkObservation = observationAssertMulti+ ["AntiPattern", "Stan0214"]+ analysis+ AntiPattern.stan0214+ let noObservation = noObservationAssert+ ["AntiPattern", "Stan0214"]+ analysis+ AntiPattern.stan0214++ it "Finds: < and >" $+ checkObservation 7 1 10 23+ it "Finds: == and <" $+ checkObservation 13 1 16 23+ it "No warning on: == on different expressions" $ do+ noObservation 19+ noObservation 20+ noObservation 21+ noObservation 22+ it "No warning on: Single >=" $ do+ noObservation 25+ noObservation 26+ noObservation 27+ it "No warning on: >= with different constants" $ do+ noObservation 30+ noObservation 31+ noObservation 32+ noObservation 33+ noObservation 34+ noObservation 35+ xit "Handles functions with pattern-matching" $+ checkObservation 41 1 44 20
+ test/Test/Stan/Analysis/Common.hs view
@@ -0,0 +1,137 @@+{- HLINT ignore "Eta reduce" -}++module Test.Stan.Analysis.Common+ ( observationAssert+ , observationAssertMulti+ , noObservationAssert+ , itShouldStr+ , unsafeNameMeta+ ) where++import FastString (FastString, mkFastString)+import SrcLoc (RealSrcSpan, mkRealSrcLoc, mkRealSrcSpan, srcSpanStartLine)+import System.FilePath (pathSeparator, (</>))+import Test.Hspec (Expectation, shouldBe)++import Stan.Analysis (Analysis (..))+import Stan.Core.Id (Id (..))+import Stan.Core.ModuleName (ModuleName (..))+import Stan.Inspection (Inspection (..), InspectionAnalysis (..))+import Stan.NameMeta (NameMeta, prettyShowNameMeta)+import Stan.Observation (Observation (..), mkObservationId)+import Stan.Pattern.Ast (PatternAst (..))++import qualified Data.Text as Text+++{- | Checks that there's 'Observation' of a given inspection in a+given line and span.+-}+observationAssert+ :: [String] -- ^ Module name+ -> Analysis+ -> Inspection+ -> Int -- ^ Line number+ -> Int -- ^ Span start+ -> Int -- ^ Span end+ -> Expectation+observationAssert moduleParts analysis inspection line start end =+ observationAssertMulti moduleParts analysis inspection line start line end++{- | Checks that there's 'Observation' of a given inspection in a+given line and span.+-}+observationAssertMulti+ :: [String] -- ^ Module name parts+ -> Analysis+ -> Inspection+ -> Int -- ^ Start Line number+ -> Int -- ^ Span start+ -> Int -- ^ End Line number+ -> Int -- ^ Span end+ -> Expectation+observationAssertMulti+ moduleParts+ analysis+ Inspection{..}+ firstLine+ start+ lastLine+ end+ =+ foundPartialObservation `shouldBe` Just expectedHeadObservation+ where+ foundPartialObservation :: Maybe Observation+ foundPartialObservation = find+ (\Observation{..} -> obsIdShort `Text.isPrefixOf` unId observationId)+ (analysisObservations analysis)++ expectedHeadObservation :: Observation+ expectedHeadObservation = Observation+ { observationId = obsId+ , observationInspectionId = inspectionId+ , observationLoc = span+ , observationFile = path+ , observationModuleName = moduleName+ , observationFileContent = maybe "" observationFileContent foundPartialObservation+ }++ obsId :: Id Observation+ obsId = mkObservationId inspectionId moduleName span++ -- Prefix of Observation Id without column number, for easier testing+ obsIdShort :: Text+ obsIdShort = Text.takeWhile (/= ':') $ unId obsId++ span :: RealSrcSpan+ span = mkRealSrcSpan+ (mkRealSrcLoc pathFS firstLine start)+ (mkRealSrcLoc pathFS lastLine end)++ path :: FilePath+ path = filePathFromParts moduleParts++ moduleName :: ModuleName+ moduleName = moduleFromParts moduleParts++ pathFS :: FastString+ pathFS = mkFastString path++-- | Checks that there's no 'Observation' of a given inspection in a given line.+noObservationAssert+ :: [String] -- ^ Module parts+ -> Analysis+ -> Inspection+ -> Int -- ^ Line number+ -> Expectation+noObservationAssert parts analysis Inspection{..} line =+ foundPartialObservation `shouldBe` Nothing+ where+ foundPartialObservation :: Maybe Observation+ foundPartialObservation = find+ (\Observation{..} ->+ observationInspectionId == inspectionId+ && observationFile == filePathFromParts parts+ && observationModuleName == moduleFromParts parts+ && srcSpanStartLine observationLoc == line+ )+ (analysisObservations analysis)++filePathFromParts :: [String] -> FilePath+filePathFromParts parts =+ "target" </> "Target" </> intercalate [pathSeparator] parts <> ".hs"++moduleFromParts :: [String] -> ModuleName+moduleFromParts parts = ModuleName $ toText $ "Target." <> intercalate "." parts++-- | Generates text to be used in tests names.+itShouldStr :: Inspection -> String+itShouldStr Inspection{..} = toString $ unId inspectionId+ <> ": finds usage of '"+ <> prettyShowNameMeta (unsafeNameMeta inspectionAnalysis)+ <> "'"++unsafeNameMeta :: InspectionAnalysis -> NameMeta+unsafeNameMeta (FindAst (PatternAstName nm _)) = nm+unsafeNameMeta (FindAst (PatternAstOr (PatternAstName nm _) _)) = nm+unsafeNameMeta _ = error "Impossible happened in tests"
+ test/Test/Stan/Analysis/Infinite.hs view
@@ -0,0 +1,35 @@+module Test.Stan.Analysis.Infinite+ ( analysisInfiniteSpec+ ) where++import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it)++import Stan.Analysis (Analysis)+import Stan.Inspection (Inspection (..), sortById)+import Stan.Inspection.Infinite (infiniteInspectionsMap)+import Stan.NameMeta (NameMeta (..))+import Test.Stan.Analysis.Common (itShouldStr, observationAssert, unsafeNameMeta)++import qualified Data.Text as T++import qualified Stan.Inspection.Infinite as Stan++analysisInfiniteSpec :: Analysis -> Spec+analysisInfiniteSpec analysis = describe "Infinite functions" $ do+ forM_ (zip (sortById infiniteInspectionsMap) [11, 14 ..]) checkObservationAuto+ checkObservation Stan.stan0103 29 23 38+ where+ checkObservation :: Inspection -> Int -> Int -> Int -> SpecWith (Arg Expectation)+ checkObservation ins l st = it (itShouldStr ins) .+ observationAssert ["Infinite"] analysis ins l st++ checkObservationAuto :: (Inspection, Int) -> SpecWith (Arg Expectation)+ checkObservationAuto (ins@Inspection{..}, line) = checkObservation ins line start end+ where+ nameMeta :: NameMeta+ nameMeta = unsafeNameMeta inspectionAnalysis++ funLen, start, end :: Int+ funLen = T.length $ nameMetaName nameMeta+ start = funLen + 8+ end = start + funLen
+ test/Test/Stan/Analysis/Partial.hs view
@@ -0,0 +1,52 @@+module Test.Stan.Analysis.Partial+ ( analysisPartialSpec+ ) where++import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it)++import Stan.Analysis (Analysis)+import Stan.Inspection (Inspection (..), sortById)+import Stan.Inspection.Partial (partialInspectionsMap)+import Stan.NameMeta (NameMeta (..))+import Test.Stan.Analysis.Common (itShouldStr, noObservationAssert, observationAssert,+ unsafeNameMeta)++import qualified Data.Text as T++import qualified Stan.Inspection.Partial as Partial+++analysisPartialSpec :: Analysis -> Spec+analysisPartialSpec analysis = describe "Partial functions" $ do+ forM_ (zip (sortById partialInspectionsMap) [16, 19 ..]) checkObservation++ let noObservation = noObservationAssert ["Partial"] analysis++ it "STAN-0010: doesn't trigger on 'succ :: Natural -> Natural'" $+ noObservation Partial.stan0010 81+ it "STAN-0011: doesn't trigger on 'pred :: Integer -> Integer'" $+ noObservation Partial.stan0011 84+ it "STAN-0011: triggers on polymorphic 'pred :: Enum a => a -> a'" $+ checkObservationFor Partial.stan0011 87 16 20+ it "STAN-0020: triggers on 'Data.List.NonEmpty.fromList'" $+ checkObservationFor Partial.stan0020 90 18 29++ where+ checkObservation :: (Inspection, Int) -> SpecWith (Arg Expectation)+ checkObservation (ins@Inspection{..}, line) = it (itShouldStr ins) $+ checkObservationFor ins line start end+ where+ nameMeta :: NameMeta+ nameMeta = unsafeNameMeta inspectionAnalysis++ funLen, start, end :: Int+ funLen = T.length $ nameMetaName nameMeta+ start = if nameMetaName nameMeta == "!!" then funLen + 14 else funLen + 8+ end = start + funLen++ checkObservationFor :: Inspection -> Int -> Int -> Int -> Expectation+ checkObservationFor ins line start end = observationAssert+ ["Partial"]+ analysis+ ins+ line start end
+ test/Test/Stan/Analysis/Style.hs view
@@ -0,0 +1,34 @@+module Test.Stan.Analysis.Style+ ( analysisStyleSpec+ ) where++import Test.Hspec (Spec, describe, it)++import Stan.Analysis (Analysis)+import Test.Stan.Analysis.Common (noObservationAssert, observationAssert)++import qualified Stan.Inspection.Style as Style+++analysisStyleSpec :: Analysis -> Spec+analysisStyleSpec analysis = describe "Style" $ do+ let checkObservation = observationAssert ["Style"] analysis+ let noObservation = noObservationAssert ["Style"] analysis++ -- fixity+ it "STAN-0301: finds operator with the missing infix" $+ checkObservation Style.stan0301 6 1 6+ it "STAN-0301: no warning when fixity is declared" $+ noObservation Style.stan0301 10++ -- big tuples+ it "STAN-0302: triggers on tuple with 4 elements in the type signature" $+ checkObservation Style.stan0302 13 16 36+ it "STAN-0302: triggers on tuple with 4 elements in the literal" $+ checkObservation Style.stan0302 14 10 22+ it "STAN-0302: no observation on triple in type" $+ noObservation Style.stan0302 16+ it "STAN-0302: no observation on triple literal" $+ noObservation Style.stan0302 17+ it "STAN-0302: triggers on tuple with 4 elements as a record field" $+ checkObservation Style.stan0302 20 20 40
+ test/Test/Stan/Cli.hs view
@@ -0,0 +1,70 @@+module Test.Stan.Cli+ ( cliSpec+ ) where++import Hedgehog (forAll, (===))+import Options.Applicative (ParserResult (Success), execParserPure)+import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Hspec.Hedgehog (hedgehog)+import Trial (fiasco, trialToMaybe, withTag)++import Stan.Cli (StanArgs (..), StanCommand (..), stanCliParser, stanParserPrefs)+import Stan.Config (Check (..), CheckFilter (..), CheckType (..), Config, ConfigP (..),+ PartialConfig, Scope (..), configToCliCommand, finaliseConfig)+import Stan.Core.Id (Id (..))+import Test.Stan.Gen (Property, genCheck, genConfig, genId, genScope)+++cliSpec :: Spec+cliSpec = describe "CLI configuration tests" $ do+ it "execParserPure . configToCliCommand ≡ pure" cliConfigRoundtripProperty+ it "Converts Config to CLI command and parses it back" $+ case execParserPure stanParserPrefs stanCliParser (stanCommand configExample) of+ Success (Stan StanArgs{..}) -> stanArgsConfig `shouldBe` partialConfigExample+ _failure -> fail "Toml-To-CLI doesn't match the original config"++ where+ configExample :: Config+ configExample = ConfigP+ { configChecks = checks+ , configRemoved = []+ , configIgnored = []+ }++ partialConfigExample :: PartialConfig+ partialConfigExample = ConfigP+ { configChecks = withTag "CLI" $ pure checks+ , configRemoved = withTag "CLI" $ fiasco "No CLI option specified for: remove"+ , configIgnored = withTag "CLI" $ fiasco "No CLI option specified for: ignore"+ }++ checks :: [Check]+ checks =+ [ Check Exclude CheckAll (ScopeDirectory "test/")+ , Check Include CheckAll ScopeAll+ , Check Exclude (CheckInspection $ Id "STAN-0002") ScopeAll+ , Check+ Exclude+ (CheckInspection $ Id "STAN-0001")+ (ScopeFile "src/MyFile.hs")+ ]++cliConfigRoundtripProperty :: Property+cliConfigRoundtripProperty = hedgehog $ do+ check <- forAll genCheck+ scope <- forAll genScope+ obs <- forAll genId+ -- we need to have a non-empty list as empty list is Fiasco for CLI.+ config <- forAll $ genConfig <&> \c -> c+ { configChecks = check : configChecks c+ , configRemoved = scope : configRemoved c+ , configIgnored = obs : configIgnored c+ }+ case execParserPure stanParserPrefs stanCliParser (stanCommand config) of+ Success (Stan StanArgs{..}) ->+ trialToMaybe (finaliseConfig stanArgsConfig) === Just config+ _failure -> fail $ "Toml-To-CLI doesn't match the original config:\n"+ <> toString (configToCliCommand config)++stanCommand :: Config -> [String]+stanCommand = filter (/= "\\") . drop 1 . map toString . words . configToCliCommand
+ test/Test/Stan/Config.hs view
@@ -0,0 +1,145 @@+module Test.Stan.Config+ ( configSpec+ ) where++import Hedgehog (forAll, (===))+import Test.Hspec (Spec, describe, it, parallel, shouldBe)+import Test.Hspec.Hedgehog (hedgehog)++import Stan.Config (Check (..), CheckFilter (..), CheckType (..), Config, ConfigP (..), Scope (..),+ applyChecks, applyChecksFor, applyConfig, mkDefaultChecks)+import Stan.Core.Id (Id (..))+import Stan.Inspection (Inspection)+import Test.Stan.Gen (Property, genCheck, genFilePath, genMediumList, genSmallList)++import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+++configSpec :: Spec+configSpec = describe "Stan Configuration Tests"+ applyChecksSpec++applyChecksSpec :: Spec+applyChecksSpec = describe "Configuration checks aggregation" $ do+ applyChecksUnitSpec+ applyChecksPropertySpec+ applyConfigSpec++applyChecksUnitSpec :: Spec+applyChecksUnitSpec = describe "applyCheck: Unit Tests" $ do+ it "All inspections when empty Check list" $+ applyChecks files [] `shouldBe` defMap+ it "Including all inspections" $+ applyChecks files [Check Include CheckAll ScopeAll] `shouldBe` defMap+ it "All inspections are excluded" $+ applyChecks files [Check Exclude CheckAll ScopeAll]+ `shouldBe` (mempty <$ defMap)+ it "Excluding single Inspection ID works" $ do+ let iId = Id "STAN-0001"+ applyChecks+ files+ [Check Exclude (CheckInspection iId) ScopeAll]+ `shouldBe`+ (HS.delete iId <$> defMap)+ it "Excluding single file works" $+ applyChecks+ files+ [Check Exclude CheckAll (ScopeFile "baz.hs")]+ `shouldBe`+ HM.adjust (const mempty) "baz.hs" defMap+ it "Excluding a directory works" $+ applyChecks+ files+ [Check Exclude CheckAll (ScopeDirectory "src/")]+ `shouldBe`+ HM.adjust (const mempty) "src/foo.hs"+ ( HM.adjust (const mempty) "src/bar.hs" defMap)+ it "Excluding inspection in a single file" $ do+ let iId = Id "STAN-0001"+ applyChecks+ files+ [Check+ Exclude+ (CheckInspection iId)+ (ScopeFile "baz.hs")+ ]+ `shouldBe`+ HM.adjust (HS.delete iId) "baz.hs" defMap++applyChecksPropertySpec :: Spec+applyChecksPropertySpec = describe "applyCheck: Property Tests" $ parallel $ do+ it "Idempotence: applyChecks . applyChecks ≡ applyChecks"+ idempotenceProperty+ it "CheckType Inversion: include c . exclude c ≡ id"+ inversionProperty++idempotenceProperty :: Property+idempotenceProperty = hedgehog $ do+ paths <- forAll $ genSmallList genFilePath+ checks <- forAll $ genMediumList genCheck++ let filesMap = mkDefaultChecks paths++ applyChecksFor (applyChecksFor filesMap checks) checks === applyChecksFor filesMap checks++inversionProperty :: Property+inversionProperty = hedgehog $ do+ paths <- forAll $ genSmallList genFilePath+ excludeCheck <- forAll $ genCheck <&> \c -> c { checkType = Exclude }+ let includeCheck = excludeCheck { checkType = Include }++ let filesMap = mkDefaultChecks paths+ applyChecksFor (applyChecksFor filesMap [excludeCheck]) [includeCheck] === filesMap++applyConfigSpec :: Spec+applyConfigSpec = describe "applyConfig tests" $ do+ it "'applyConfig' with no removed files is the same as 'applyChecks'" $ do+ let checks = [Check Exclude CheckAll ScopeAll]+ applyConfig files (emptyConfig{ configChecks = checks })+ `shouldBe` applyChecks files checks+ it "Removes all files" $+ applyConfig files removeAllConfig `shouldBe` mempty+ it "Removes a single file" $+ applyConfig files removeFileConfig+ `shouldBe` HM.delete "baz.hs" defMap+ it "Removes all files from a directory" $+ applyConfig files removeDirectoryConfig+ `shouldBe` HM.delete "src/foo.hs" (HM.delete "src/bar.hs" defMap)+ it "Removes 2 files" $+ applyConfig files removeTwoFilesConfig+ `shouldBe` HM.delete "src/foo.hs" (HM.delete "baz.hs" defMap)+ it "Removes all files when they are specified explicitly" $+ applyConfig files removeAllExplicitConfig `shouldBe` mempty+ where+ emptyConfig :: Config+ emptyConfig = ConfigP+ { configChecks = []+ , configRemoved = []+ , configIgnored = []+ }++ removeAllConfig :: Config+ removeAllConfig = emptyConfig { configRemoved = [ScopeAll] }++ removeFileConfig :: Config+ removeFileConfig = emptyConfig { configRemoved = [ScopeFile "baz.hs"] }++ removeDirectoryConfig :: Config+ removeDirectoryConfig = emptyConfig { configRemoved = [ScopeDirectory "src/"] }++ removeTwoFilesConfig :: Config+ removeTwoFilesConfig = emptyConfig+ { configRemoved = [ScopeFile "baz.hs", ScopeFile "src/foo.hs"]+ }++ removeAllExplicitConfig :: Config+ removeAllExplicitConfig = emptyConfig+ { configRemoved = [ScopeFile "baz.hs", ScopeDirectory "src"]+ }++files :: [FilePath]+files = ["src/foo.hs", "src/bar.hs", "baz.hs"]++defMap :: HashMap FilePath (HashSet (Id Inspection))+defMap = mkDefaultChecks files
+ test/Test/Stan/Gen.hs view
@@ -0,0 +1,120 @@+module Test.Stan.Gen+ ( Property+ , genFilePath+ , genId+ , genMediumList+ , genSmallList+ , genSmallString+ , genSmallText++ -- * Config+ , genConfig+ , genCheck+ , genCheckType+ , genCheckFilter+ , genScope+ , genSeverity+ , genCategory+ , genModuleName+ ) where++import Hedgehog (Gen, PropertyT)+import System.FilePath ((</>))++import Stan.Category (Category, stanCategories)+import Stan.Config (Check (..), CheckFilter (..), CheckType (..), Config, ConfigP (..), Scope (..))+import Stan.Core.Id (Id (..))+import Stan.Core.ModuleName (ModuleName (..))+import Stan.Inspection (Inspection)+import Stan.Inspection.All (inspectionsIds)+import Stan.Severity (Severity)++import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+++-- | Helper alias for tests.+type Property = PropertyT IO ()++-- | Generate an 'Int'.+genId :: Gen (Id a)+genId = Id <$> genSmallText++-- | Generate valid 'Inspection' 'Id's.+genInspectionId :: Gen (Id Inspection)+genInspectionId = Gen.element $ toList inspectionsIds++-- | Generate a small list of the given generated elements.+genSmallList :: Gen a -> Gen [a]+genSmallList = Gen.list (Range.linear 0 6)++-- | Generate a medium-size list+genMediumList :: Gen a -> Gen [a]+genMediumList = Gen.list (Range.linear 0 50)++genSmallText :: Gen Text+genSmallText = Gen.text (Range.linear 0 10) Gen.alphaNum++genSmallString :: Gen String+genSmallString = Gen.string (Range.linear 0 10) Gen.alphaNum++genConfig :: Gen Config+genConfig = ConfigP+ <$> genSmallList genCheck+ <*> genSmallList genScope+ <*> genSmallList genId++genCheck :: Gen Check+genCheck = Check+ <$> genCheckType+ <*> genCheckFilter+ <*> genScope++genCheckFilter :: Gen CheckFilter+genCheckFilter = Gen.choice+ [ CheckInspection <$> genInspectionId+ , CheckSeverity <$> genSeverity+ , CheckCategory <$> genCategory+ , pure CheckAll+ ]++genScope :: Gen Scope+genScope = Gen.choice+ [ ScopeFile <$> genFilePath+ , ScopeDirectory <$> genDirectory+ , pure ScopeAll+ ]++-- | Output one of the hardcoded directories+genDirectory :: Gen FilePath+genDirectory = Gen.element+ [ "src"+ , "app"+ , "lib/"+ , "test/"+ , "benchmark/"+ , "app/main/"+ , "src/app"+ , "src/lib/"+ , "src/lib/foo"+ , "src/lib/bar/"+ ]++-- | Generate a filepath either plain or from a predefined directory+genFilePath :: Gen FilePath+genFilePath = Gen.choice+ [ genSmallString+ , liftA2 (</>) genDirectory genSmallString+ ]++genCheckType :: Gen CheckType+genCheckType = Gen.enumBounded++genSeverity :: Gen Severity+genSeverity = Gen.enumBounded++genCategory :: Gen Category+genCategory = Gen.element stanCategories++genModuleName :: Gen ModuleName+genModuleName = ModuleName <$> genSmallText
+ test/Test/Stan/Number.hs view
@@ -0,0 +1,20 @@+module Test.Stan.Number+ ( linesOfCodeSpec+ , modulesNumSpec+ ) where++import HieTypes (HieFile (..))+import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)++import Stan.Hie (countLinesOfCode)+++linesOfCodeSpec :: HieFile -> Spec+linesOfCodeSpec hieFile = describe "LoC tests" $+ it "should count lines of code in the example file" $+ countLinesOfCode hieFile `shouldBe` 90++modulesNumSpec :: Int -> Spec+modulesNumSpec num = describe "Modules number tests" $+ it "should count correct number of modules" $+ num `shouldSatisfy` (> 56)
+ test/Test/Stan/Observation.hs view
@@ -0,0 +1,25 @@+module Test.Stan.Observation+ ( observationSpec+ ) where++import SrcLoc (mkRealSrcLoc, mkRealSrcSpan)+import Test.Hspec (Spec, describe, it, shouldBe)++import Stan.Core.Id (Id (..))+import Stan.Inspection (inspectionId)+import Stan.Inspection.Partial (stan0001)+import Stan.Observation (Observation, mkObservationId)+++observationSpec :: Spec+observationSpec = describe "Observation" $+ it "calculates Observation Id properly" $+ testObservationId `shouldBe` Id "OBS-STAN-0001-bbjjJQ-10:42"+ where+ testObservationId :: Id Observation+ testObservationId = mkObservationId+ (inspectionId stan0001)+ "Test.Module.Name"+ $ mkRealSrcSpan+ (mkRealSrcLoc "src/Test/Module/Name.hs" 10 42)+ (mkRealSrcLoc "src/Test/Module/Name.hs" 10 42)
+ test/Test/Stan/Toml.hs view
@@ -0,0 +1,54 @@+module Test.Stan.Toml+ ( tomlSpec+ ) where++import Hedgehog (forAll, (===))+import Test.Hspec (Spec, describe, it, shouldReturn)+import Test.Hspec.Hedgehog (hedgehog)+import Trial (Trial (..), fiasco, withTag)++import Stan.Config (Check (..), CheckFilter (..), CheckType (..), Config, ConfigP (..),+ PartialConfig, Scope (..), finaliseConfig)+import Stan.Core.Id (Id (..))+import Stan.Toml (configCodec)+import Test.Stan.Gen (Property, genConfig)++import qualified Toml+++tomlSpec :: Spec+tomlSpec = describe "TOML configuration tests" $ do+ it "decode . encode ≡ pure" configTomlRoundtripProperty+ it "Parses test/.stan.example.toml" $+ Toml.decodeFile configCodec "test/.stan-example.toml" `shouldReturn` configExample+ where+ configExample :: PartialConfig+ configExample = ConfigP+ { configChecks = withTag "TOML" $ pure+ [ Check Exclude CheckAll (ScopeDirectory "test/")+ , Check Include CheckAll ScopeAll+ , Check Exclude (CheckInspection $ Id "STAN-0002") ScopeAll+ , Check+ Exclude+ (CheckInspection $ Id "STAN-0001")+ (ScopeFile "src/MyFile.hs")+ ]+ , configRemoved = withTag "TOML" $ pure [] <> fiasco "No TOML value is specified for key: remove"+ , configIgnored = withTag "TOML" $ pure [] <> fiasco "No TOML value is specified for key: ignore"+ }++configTomlRoundtripProperty :: Property+configTomlRoundtripProperty = hedgehog $ do+ config <- forAll genConfig+ case Toml.decode configCodec $ Toml.encode configCodec $ toPartialConfig config of+ Right partialConfig -> case finaliseConfig partialConfig of+ Result _ res -> config === res+ Fiasco _ -> fail "Expected Result, but this is Fiasco, bro"+ Left _ -> fail "Expected Right"++toPartialConfig :: Config -> PartialConfig+toPartialConfig ConfigP{..} = ConfigP+ { configChecks = withTag "TOML" $ pure configChecks+ , configRemoved = withTag "TOML" $ pure configRemoved+ , configIgnored = withTag "TOML" $ pure configIgnored+ }