diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,497 @@ +# Stan + +

Stan Logo

+ +[![GitHub CI](https://github.com/kowainik/stan/workflows/CI/badge.svg)](https://github.com/kowainik/stan/actions) +[![Hackage](https://img.shields.io/hackage/v/stan.svg)](https://hackage.haskell.org/package/stan) +[![MPL-2.0 license](https://img.shields.io/badge/license-MPL--2.0-blue.svg)](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: + +![Stan terminal example](https://user-images.githubusercontent.com/4276606/85208720-89326100-b32a-11ea-94fd-4aa149626b74.png) + +## 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. + +![Configuration explanation](https://user-images.githubusercontent.com/4276606/85208889-bb908e00-b32b-11ea-8256-c576a33cbf38.png) + +### 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 diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Stan (run) + + +main :: IO () +main = run diff --git a/src/Stan.hs b/src/Stan.hs new file mode 100644 --- /dev/null +++ b/src/Stan.hs @@ -0,0 +1,149 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Analysis.hs b/src/Stan/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Analysis.hs @@ -0,0 +1,182 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Analysis/Analyser.hs b/src/Stan/Analysis/Analyser.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Analysis/Analyser.hs @@ -0,0 +1,409 @@ +{-# LANGUAGE BangPatterns #-} + +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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) diff --git a/src/Stan/Analysis/Pretty.hs b/src/Stan/Analysis/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Analysis/Pretty.hs @@ -0,0 +1,174 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Analysis/Summary.hs b/src/Stan/Analysis/Summary.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Analysis/Summary.hs @@ -0,0 +1,97 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Cabal.hs b/src/Stan/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Cabal.hs @@ -0,0 +1,132 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Category.hs b/src/Stan/Category.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Category.hs @@ -0,0 +1,79 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +__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 + ] diff --git a/src/Stan/Cli.hs b/src/Stan/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Cli.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE ApplicativeDo #-} + +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Config.hs b/src/Stan/Config.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Config.hs @@ -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 + +@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" + @ +-} diff --git a/src/Stan/Config/Pretty.hs b/src/Stan/Config/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Config/Pretty.hs @@ -0,0 +1,92 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +@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 /= ""] diff --git a/src/Stan/Core/Id.hs b/src/Stan/Core/Id.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Core/Id.hs @@ -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 + +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 diff --git a/src/Stan/Core/List.hs b/src/Stan/Core/List.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Core/List.hs @@ -0,0 +1,46 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Core/ModuleName.hs b/src/Stan/Core/ModuleName.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Core/ModuleName.hs @@ -0,0 +1,31 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/EnvVars.hs b/src/Stan/EnvVars.hs new file mode 100644 --- /dev/null +++ b/src/Stan/EnvVars.hs @@ -0,0 +1,41 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 _ -> "" diff --git a/src/Stan/Example.hs b/src/Stan/Example.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Example.hs @@ -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 + +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 + } diff --git a/src/Stan/FileInfo.hs b/src/Stan/FileInfo.hs new file mode 100644 --- /dev/null +++ b/src/Stan/FileInfo.hs @@ -0,0 +1,57 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Ghc/Compat.hs b/src/Stan/Ghc/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Ghc/Compat.hs @@ -0,0 +1,59 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 (..)) diff --git a/src/Stan/Hie.hs b/src/Stan/Hie.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Hie.hs @@ -0,0 +1,99 @@ +{- HLINT ignore "Redundant if" -} + +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Hie/Compat.hs b/src/Stan/Hie/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Hie/Compat.hs @@ -0,0 +1,40 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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) diff --git a/src/Stan/Hie/Debug.hs b/src/Stan/Hie/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Hie/Debug.hs @@ -0,0 +1,80 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE StandaloneDeriving #-} + +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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{..} diff --git a/src/Stan/Hie/MatchAst.hs b/src/Stan/Hie/MatchAst.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Hie/MatchAst.hs @@ -0,0 +1,92 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Hie/MatchType.hs b/src/Stan/Hie/MatchType.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Hie/MatchType.hs @@ -0,0 +1,83 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Info.hs b/src/Stan/Info.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Info.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE TemplateHaskell #-} + +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +@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) diff --git a/src/Stan/Inspection.hs b/src/Stan/Inspection.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Inspection.hs @@ -0,0 +1,163 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +__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 diff --git a/src/Stan/Inspection/All.hs b/src/Stan/Inspection/All.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Inspection/All.hs @@ -0,0 +1,55 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Inspection/AntiPattern.hs b/src/Stan/Inspection/AntiPattern.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Inspection/AntiPattern.hs @@ -0,0 +1,390 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 "\\\\") diff --git a/src/Stan/Inspection/Infinite.hs b/src/Stan/Inspection/Infinite.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Inspection/Infinite.hs @@ -0,0 +1,96 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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) diff --git a/src/Stan/Inspection/Partial.hs b/src/Stan/Inspection/Partial.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Inspection/Partial.hs @@ -0,0 +1,289 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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) + "" diff --git a/src/Stan/Inspection/Style.hs b/src/Stan/Inspection/Style.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Inspection/Style.hs @@ -0,0 +1,67 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 + } diff --git a/src/Stan/NameMeta.hs b/src/Stan/NameMeta.hs new file mode 100644 --- /dev/null +++ b/src/Stan/NameMeta.hs @@ -0,0 +1,182 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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") diff --git a/src/Stan/Observation.hs b/src/Stan/Observation.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Observation.hs @@ -0,0 +1,262 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +__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--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 diff --git a/src/Stan/Pattern/Ast.hs b/src/Stan/Pattern/Ast.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Pattern/Ast.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE CPP #-} + +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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") diff --git a/src/Stan/Pattern/Edsl.hs b/src/Stan/Pattern/Edsl.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Pattern/Edsl.hs @@ -0,0 +1,40 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 &&& diff --git a/src/Stan/Pattern/Type.hs b/src/Stan/Pattern/Type.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Pattern/Type.hs @@ -0,0 +1,182 @@ +{- HLINT ignore "Avoid lambda using `infix`" -} + +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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" diff --git a/src/Stan/Report.hs b/src/Stan/Report.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Report.hs @@ -0,0 +1,29 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Report/Css.hs b/src/Stan/Report/Css.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Report/Css.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE PostfixOperators #-} + +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Report/Html.hs b/src/Stan/Report/Html.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Report/Html.hs @@ -0,0 +1,453 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Report/Settings.hs b/src/Stan/Report/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Report/Settings.hs @@ -0,0 +1,47 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Severity.hs b/src/Stan/Severity.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Severity.hs @@ -0,0 +1,72 @@ +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Stan/Toml.hs b/src/Stan/Toml.hs new file mode 100644 --- /dev/null +++ b/src/Stan/Toml.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE ApplicativeDo #-} + +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +@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 diff --git a/stan.cabal b/stan.cabal new file mode 100644 --- /dev/null +++ b/stan.cabal @@ -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 +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 diff --git a/target/Target/AntiPattern.hs b/target/Target/AntiPattern.hs new file mode 100644 --- /dev/null +++ b/target/Target/AntiPattern.hs @@ -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" diff --git a/target/Target/AntiPattern/Stan0206.hs b/target/Target/AntiPattern/Stan0206.hs new file mode 100644 --- /dev/null +++ b/target/Target/AntiPattern/Stan0206.hs @@ -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 diff --git a/target/Target/AntiPattern/Stan0206Extensions.hs b/target/Target/AntiPattern/Stan0206Extensions.hs new file mode 100644 --- /dev/null +++ b/target/Target/AntiPattern/Stan0206Extensions.hs @@ -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 diff --git a/target/Target/AntiPattern/Stan0212.hs b/target/Target/AntiPattern/Stan0212.hs new file mode 100644 --- /dev/null +++ b/target/Target/AntiPattern/Stan0212.hs @@ -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 diff --git a/target/Target/AntiPattern/Stan0213.hs b/target/Target/AntiPattern/Stan0213.hs new file mode 100644 --- /dev/null +++ b/target/Target/AntiPattern/Stan0213.hs @@ -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" diff --git a/target/Target/AntiPattern/Stan0214.hs b/target/Target/AntiPattern/Stan0214.hs new file mode 100644 --- /dev/null +++ b/target/Target/AntiPattern/Stan0214.hs @@ -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 diff --git a/target/Target/Infinite.hs b/target/Target/Infinite.hs new file mode 100644 --- /dev/null +++ b/target/Target/Infinite.hs @@ -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 diff --git a/target/Target/Partial.hs b/target/Target/Partial.hs new file mode 100644 --- /dev/null +++ b/target/Target/Partial.hs @@ -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 diff --git a/target/Target/Style.hs b/target/Target/Style.hs new file mode 100644 --- /dev/null +++ b/target/Target/Style.hs @@ -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) + } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 diff --git a/test/Test/Stan/Analysis.hs b/test/Test/Stan/Analysis.hs new file mode 100644 --- /dev/null +++ b/test/Test/Stan/Analysis.hs @@ -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 diff --git a/test/Test/Stan/Analysis/AntiPattern.hs b/test/Test/Stan/Analysis/AntiPattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Stan/Analysis/AntiPattern.hs @@ -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 diff --git a/test/Test/Stan/Analysis/Common.hs b/test/Test/Stan/Analysis/Common.hs new file mode 100644 --- /dev/null +++ b/test/Test/Stan/Analysis/Common.hs @@ -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" diff --git a/test/Test/Stan/Analysis/Infinite.hs b/test/Test/Stan/Analysis/Infinite.hs new file mode 100644 --- /dev/null +++ b/test/Test/Stan/Analysis/Infinite.hs @@ -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 diff --git a/test/Test/Stan/Analysis/Partial.hs b/test/Test/Stan/Analysis/Partial.hs new file mode 100644 --- /dev/null +++ b/test/Test/Stan/Analysis/Partial.hs @@ -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 diff --git a/test/Test/Stan/Analysis/Style.hs b/test/Test/Stan/Analysis/Style.hs new file mode 100644 --- /dev/null +++ b/test/Test/Stan/Analysis/Style.hs @@ -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 diff --git a/test/Test/Stan/Cli.hs b/test/Test/Stan/Cli.hs new file mode 100644 --- /dev/null +++ b/test/Test/Stan/Cli.hs @@ -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 diff --git a/test/Test/Stan/Config.hs b/test/Test/Stan/Config.hs new file mode 100644 --- /dev/null +++ b/test/Test/Stan/Config.hs @@ -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 diff --git a/test/Test/Stan/Gen.hs b/test/Test/Stan/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Test/Stan/Gen.hs @@ -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 diff --git a/test/Test/Stan/Number.hs b/test/Test/Stan/Number.hs new file mode 100644 --- /dev/null +++ b/test/Test/Stan/Number.hs @@ -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) diff --git a/test/Test/Stan/Observation.hs b/test/Test/Stan/Observation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Stan/Observation.hs @@ -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) diff --git a/test/Test/Stan/Toml.hs b/test/Test/Stan/Toml.hs new file mode 100644 --- /dev/null +++ b/test/Test/Stan/Toml.hs @@ -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 + }