summoner 1.1.0.1 → 1.2.0
raw patch · 35 files changed
+2098/−1247 lines, 35 filesdep +basedep +hspecdep −tastydep −tasty-hedgehogdep ~base-nopreludedep ~filepathdep ~hedgehog
Dependencies added: base, hspec
Dependencies removed: tasty, tasty-hedgehog
Dependency ranges changed: base-noprelude, filepath, hedgehog, neat-interpolation, relude, tomland
Files
- CHANGELOG.md +68/−27
- README.md +406/−154
- app/Cli.hs +8/−0
- app/Main.hs +0/−8
- src/Prelude.hs +11/−1
- src/Summoner.hs +13/−24
- src/Summoner/Ansi.hs +7/−8
- src/Summoner/CLI.hs +130/−68
- src/Summoner/Config.hs +23/−38
- src/Summoner/Decision.hs +5/−5
- src/Summoner/Default.hs +5/−5
- src/Summoner/GhcVer.hs +53/−8
- src/Summoner/License.hs +39/−3
- src/Summoner/Process.hs +2/−5
- src/Summoner/Project.hs +113/−81
- src/Summoner/ProjectData.hs +0/−42
- src/Summoner/Question.hs +110/−22
- src/Summoner/Settings.hs +54/−0
- src/Summoner/Source.hs +38/−15
- src/Summoner/Template.hs +19/−632
- src/Summoner/Template/Cabal.hs +201/−0
- src/Summoner/Template/Doc.hs +105/−0
- src/Summoner/Template/GitHub.hs +266/−0
- src/Summoner/Template/Haskell.hs +92/−0
- src/Summoner/Template/Stack.hs +39/−0
- src/Summoner/Text.hs +6/−1
- src/Summoner/Tree.hs +27/−18
- src/Summoner/Validation.hs +0/−27
- summoner.cabal +46/−34
- test/Prelude.hs +9/−0
- test/Spec.hs +27/−1
- test/Test/DecisionSpec.hs +13/−8
- test/Test/Golden.hs +134/−0
- test/Test/QuestionSpec.hs +12/−0
- test/Test/TomlSpec.hs +17/−12
CHANGELOG.md view
@@ -1,14 +1,60 @@-# Summoner+# Changelog -1.1.0.1-=======+`summoner` uses [PVP Versioning][1].+The changelog is available [on GitHub][2]. +## 1.2.0 — Nov 30, 2018++* Make `cabal-version: 2.0` default in generated projects.+* [#11](https://github.com/kowainik/summoner/issues/11):+ Support offline mode.+* [#199](https://github.com/kowainik/summoner/issues/199):+ Add `None` license with no `LICENSE` file generation.+ Add licenses short descriptions text during the interactive mode.+ Patch `summon show license` command to show short description about+ each license.+* [#197](https://github.com/kowainik/summoner/issues/197)+ Build with `stack` lts-12.20, and support `GHC` 8.4.4 in+ project generation. Make GHC-8.4.4 the default one for generated project.+* [#37](https://github.com/kowainik/summoner/issues/37):+ Add HLint check on Travis CI in generatd projects.+* [#142](https://github.com/kowainik/summoner/issues/142):+ Add version bounds to `base` in the generated `.cabal` file.+* [#239](https://github.com/kowainik/summoner/issues/239):+ Make categories not mandatory.+* Use `defaultDescription` for project description if not specified.+* [#185](https://github.com/kowainik/summoner/issues/185):+ Add golden tests.+* [#184](https://github.com/kowainik/summoner/issues/184)+ Add `--no-upload` option.+* [#169](https://github.com/kowainik/summoner/issues/169):+ Make AppVeyor use the 64bits version of stack and build for 64 bits.+* [#154](https://github.com/kowainik/summoner/issues/154):+ Add `Link` constructor to `Source` data type.+* [#178](https://github.com/kowainik/summoner/issues/178):+ Remove unnecessary new lines and trailing spaces in most places.+* [#168](https://github.com/kowainik/summoner/issues/168):+ Upgrade `stack` `intall-cabal` option's version to `2.2.0.1` in+ the generated Travis file.+* [#195](https://github.com/kowainik/summoner/issues/195):+ Update prompt questions for CLI.+* Add more documentation to the functions.+* [#155](https://github.com/kowainik/summoner/issues/155):+ Bump up to `tomland-0.5.0`.+* [#202](https://github.com/kowainik/summoner/issues/202):+ Bump up to `relude-0.4.0`.+* Remove `tasty` dependencies from tests.+* Drop support for GHC-8.6.1 on CI. Support GHC-8.6.2 on CI.+* Drop support for GHC-8.4.3 on CI. Build with GHC-8.4.4 on CI.++## 1.1.0.1 – Sep 10, 2018+ * Bump up `relude` version to `0.3.0`. * [#146](https://github.com/kowainik/summoner/issues/146): Migrate to `base-noprelude`.+* Add -Werror to build option in generated .travis.yml -1.1.0-=====+## 1.1.0 * [#128](https://github.com/kowainik/summoner/issues/128): __Important:__ Replace `summon` with `summon new` command.@@ -52,15 +98,13 @@ * [#27](https://github.com/kowainik/summoner/issues/27): Remove `b` script. -1.0.6-=====+## 1.0.6 * Use `relude` instead of `universum`. * [#105](https://github.com/kowainik/summoner/issues/105): Add `--ignore-config` option. -1.0.5-=====+## 1.0.5 * [#100](https://github.com/kowainik/summoner/issues/100): Bump up to `ghc-8.4.3`. Add support for `Ghc843` in code@@ -73,30 +117,27 @@ * [#96](https://github.com/kowainik/summoner/issues/96): Add option to choose `cabal`, `stack` or both. -1.0.4-=====+## 1.0.4+ * Bump up `tomland` to version `0.3`. -1.0.3-=====+## 1.0.3+ * [#92](https://github.com/kowainik/summoner/issues/92): Remove -fhide-source-paths from generated stack yaml files for GHC < 8.2 -1.0.2-=====+## 1.0.2 * [#87](https://github.com/kowainik/summoner/issues/87): Fix Travis matrix for not default `ghc` versions. -1.0.1-=====+## 1.0.1 * [#85](https://github.com/kowainik/summoner/issues/85): Remove `base-noprelude` from dependencies. -1.0.0-=====+## 1.0.0 * __Important:__ Rename `hs-init` to `summoner`. Transform the script into the package. * [#54](https://github.com/kowainik/summoner/issues/54):@@ -123,26 +164,26 @@ # hs-init -0.0.4-=====+## 0.0.4+ * Now works on windows systems as well * Add powershell install script for Windows -0.0.3-=====+## 0.0.3 * [#45](https://github.com/vrom911/hs-init/issues/45): Support AppVeyor CI for created projects. -0.0.2-=====+## 0.0.2 * Use metavar for on-off commands. * Upgrade `lts` to `10.3`, use `ghc 8.2.2` as default value. -0.0.1-=====+## 0.0.1 * [#36](https://github.com/vrom911/hs-init/issues/36): Add option for creating private repositories — `-p | --private`.++[1]: https://pvp.haskell.org+[2]: https://github.com/kowainik/summoner/releases
README.md view
@@ -1,141 +1,344 @@ # 🔮 Summoner -[](http://travis-ci.org/kowainik/summoner)-[](https://github.com/kowainik/summoner/blob/master/LICENSE)+[](http://travis-ci.org/kowainik/summoner)+[](https://ci.appveyor.com/project/kowainik/summoner) [](https://hackage.haskell.org/package/summoner)-[](http://stackage.org/lts/package/summoner)-[](http://stackage.org/nightly/package/summoner)-[](http://packdeps.haskellers.com/reverse/summoner)+[](https://github.com/kowainik/summoner/blob/master/LICENSE) > _So many of our dreams at first seem impossible, then they seem improbable, and > then, when we summon the will, they soon become inevitable._ > > Christopher Reeve -Summoner is the tool for creating fully configured production Haskell projects.+Summoner is a tool for scaffolding fully configured batteries-included production Haskell projects. -## Demo+Do you want to create a library that is to be uploaded to Hackage/Stackage, that builds with both Cabal and Stack and supports the latest three major GHC versions?+Or you are building a production application which uses a custom prelude and has CI with Travis Linux and AppVeyors Windows checks?+Summoner can help you do all that with minimal effort from you - it can even upload the project to GitHub if you wish! -[](https://asciinema.org/a/198918)+By the way, Summoner operates as either CLI or TUI application, so you can choose what you're more comfortable with and install only the required one. -## Getting started+## Structure -### Prerequisites+* [Demo](#demo-)+ + [TUI demo](#tui-demo-)+ + [CLI demo](#cli-demo-)+ + [Scaffolded project structure](#scaffolded-project-structure-)+* [Features](#features-)+* [Get started](#get-started-)+ + [Prerequisites](#prerequisites-)+ + [Installation](#installation-)+ + [Summon-TUI](#summon-tui-)+ + [TUI: download binary](#tui-download-binary-)+ + [TUI: from source](#tui-from-source-)+ + [Summon-CLI](#summon-cli-)+ + [CLI: download binary](#cli-download-binary-)+ + [CLI: from Hackage/Stackage](#cli-from-hackagestackage-)+ + [CLI: from source](#cli-from-source-)+ + [Setup](#setup-)+* [Usage](#usage-)+ + [Command-line arguments](#command-line-arguments-)+ + [File configuration](#file-configuration-)+ + [TUI](#tui-)+ + [CLI](#cli-)+* [For Developers](#for-developers-)+ + [Build](#build-)+ + [Test](#test-)+ + [Run](#run-)+* [Changelog](#changelog-)+* [Acknowledgments](#acknowledgments-) -To start using it make sure you have the next tools installed on your machine:+## Demo [↑](#structure) -* [`Stack`](http://haskellstack.org) or [`cabal`](https://www.haskell.org/cabal/)-* [`git`](https://git-scm.com)-* [`hub`](https://github.com/github/hub)-* [`curl`](https://curl.haxx.se)+### TUI demo [↑](#structure) -### Installation+[](https://asciinema.org/a/214424) -The installation process can be done with the one simple command:+### CLI demo [↑](#structure) - $ cabal new-install summoner+[](https://asciinema.org/a/214433) -or+### Scaffolded project structure [↑](#structure) - $ stack install summoner+This is an example of the project hierarchy you can get if you're running Summoner with all options enabled: -or directly from GitHub.+```+project-name/+├── app/+│ └── Main.hs+├── benchmark/+│ └── Main.hs+├── src/+│ ├── ProjectName.hs+│ └── Prelude.hs+├── test/+│ └── Spec.hs+├── CHANGELOG.md+├── CONTRIBUTING.md+├── LICENSE+├── project-name.cabal+├── README.md+├── Setup.hs+├── stack.yaml+├── appveyor.yml+├── .git+├── .gitignore+├── .stylish-haskell.yaml+└── .travis.yml+``` -You can turn on the bash auto-completion by running the following command:+You can also see complete examples in the following folder: +* [`summon-cli/tests/golden`: Examples of scaffolded projects](https://github.com/kowainik/summoner/tree/master/summoner-cli/test/golden)++Directory `smallProject` contains an example of the straightforward package, and `fullProject` shows a generated project with more advanced structure and more features.++## Features [↑](#structure)++Summoner is a tool that combines predefined configurations, command-line arguments and a chosen interface.++To fully understand the power in your hands with the help of Summoner, please check out this section.++Below you can see highlighted features in different categories.++### Project [↑](#structure)+++ Support for Cabal and Stack build tools.++ Ability to pick stanzas (library, executable, test-suite, benchmark).++ Option to include an alternative prelude, if desired. The project would then use [`base-noprelude` technique](http://hackage.haskell.org/package/Prelude), and the `Prelude` module would be added to the library target.++ Whole Hackage-upload checklist support.++ Support for multiple GHC versions, with thoughtful reflection on project meta, base versions (e.g. `base >= 4.9 && < 4.12`), etc.++ Different license support: MIT, BSD2, BSD3, GPL-2, GPL-3, LGPL-2.1, LGPL-3, AGPL-3, Apache-2.0, MPL-2.0, None (All Rights Reserved license without file).++ Creation of the `CHANGELOG.md` file with [PVP versioning policy](https://pvp.haskell.org).++ Ability to include your `.stylish-haskell.yaml` file.++ Usage of the `ghc-options` field with sensible defaults.++ If warnings are not explicitly stated in the configuration file, then the following list of GHC flags is added to all stanzas:++ ```+ -Wall+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wcompat+ -Widentities+ -Wredundant-constraints (ghc >= 8.0)+ -fhide-source-paths (ghc >= 8.2.2)+ -Wmissing-export-lists (ghc >= 8.4.1)+ -Wpartial-fields (ghc >= 8.4.1)+ ```++ Besides, the following GHC options are added to the executable, tests and benchmark stanzas:++ ```+ -threaded+ -rtsopts+ -with-rtsopts=-N+ ```++### GitHub [↑](#structure)+++ Initialisation of the git repository inside the project folder.++ Initial commit creation.++ Uploading the repository to GitHub.++ Exhaustive `.gitignore` file.++ Formation of the `README` file with Hackage, Stackage and CI badges.++ Linking to the GitHub repository in the `.cabal` file.++ Ability to include your `CONTRIBUTING.md` file.++### CI [↑](#structure)+++ Generation of the `.travis.yml` file that runs build and tests on CI under Linux.++ Configuration matrix on CI to build with multiple GHC versions and various build tools.++ `-Werror` is enabled on CI not to miss any warnings.++ Run HLint checks on CI.++ Generation of the `appveyor.yaml` file which runs build and tests on CI under Windows.++### Others [↑](#structure)+++ Ability to create a project in offline mode.++## Get started [↑](#structure)++### Prerequisites [↑](#structure)++To start using Summoner make sure that you have the following tools installed on your machine:++* [`git`](https://git-scm.com) – to initialize the GitHub repo.+* [`hub`](https://github.com/github/hub) – to upload the project to GitHub.+* [`curl`](https://curl.haxx.se) – to download licenses.++### Installation [↑](#structure)++Summon contains two executables:++* `summon`: scaffold projects using interactive CLI mode.+* `summon-tui`: scaffold projects using TUI.++Below you can find the description of how to install each of them so you can choose the one you want.++#### Summon-TUI [↑](#structure)++> **NOTE:** `summon-tui` is not supported on Windows. See [this issue](https://github.com/jtdaugherty/vty/pull/1).++##### TUI: download binary [↑](#structure)++You can download binary directly [from GitHub releases](https://github.com/kowainik/summoner/releases).++After downloading binary, make it executable and copy it under convenient location, for example:++```shell+chmod +x summon-cli-linux+mv summon-cli-linux ~/.local/bin/summon ```-$ source <(summon --bash-completion-script `which summon`)++##### TUI: from source [↑](#structure)++Fetch the repo using `cabal`:++```shell+cabal get -s summoner ``` -After that, you can call `summon` with the required command. To create a-project, use `summon new` command specifying the prefered CLI options, follow-the instructions during the interactive process of the project creation, and a-new project would be created in a subfolder as well as a repository under your-GitHub account (if requested).+or clone the directory from GitHub: -### Usage+```shell+git clone https://github.com/kowainik/summoner.git+``` -There are several options how to set particular configurations for the new projects:+Step into the directory: -1. Default configuration file (`~/.summoner.toml`).-2. Explicitly specified configuration file by `--file FILENAME` option (used- instead of the default one if specified).-3. Options that are stated by CLI arguments.-4. Interactively inputed answers during work of the `summon` command- (for the options that were not specified on previous steps).+```haskell+cd summoner+``` -So, the configuration uses [`Partial Options Monoid Pattern`](https://medium.com/@jonathangfischoff/the-partial-options-monoid-pattern-31914a71fc67).+Build and install using `cabal`: -If none of the mentioned above cases used then the configuration will be built interactively.+```shell+cabal new-install summoner-tui:exe:summon-tui+``` -#### Configurations+Build and install using `stack`: -##### `.toml` files:+```shell+stack install summoner-tui:exe:summon-tui+``` -Here is the list of the options that could be configured for your needs:+#### Summon-CLI [↑](#structure) -###### Global keys+##### CLI: download binary [↑](#structure) -* `cabal` – `true` if you want to build you project with `cabal`,- `false` if you don't. If not specified it would be asked during each run of the `summoner`.-* `stack` – `true` if you want to build your project with `stack`,- `false` if you don't. If not specified it would be asked during each run of the `summoner`.-* `owner` – `GitHub` login.-* `fullName` – full name.-* `email` – e-mail address.-* `license` – license (possible options: `MIT`, `BSD2`, `BSD3`, `GPL-2`, `GPL-3`,- `LGPL-2.1`, `LGPL-3`, `AGPL-3`, `Apache-2.0`, `MPL-2.0`).-* `ghcVersions` – `summoner` uses default `GHC-8.2.2`. But additionally you can specify other versions.- For each version `x.y.z` the `stack-x.y.z.yaml` will be created.-* `github` – `true` if you want to turn on `GitHub` integration by default,- `false` if you don't. If not specified it would be asked during each run of the `summoner`.-* `travis` – `true` if you want to turn on `Travis` integration by default,- `false` if you don't. Ignored if `github = false`.- If not specified it would be asked during each run of the `summoner`.-* `appveyor` – `true` if you want to turn on `AppVeyor` integration by default,- `false` if you don't. Ignored if `github = false`.- If not specified it would be asked during each run of the `summoner`.-* `private` – `true` if you want to create private repositories by default,- `false` if you don't. Ignored if `github = false`.- If not specified it would be asked during each run of the `summoner`.-* `lib` – `true` if you want to create `src` folder with dummy `Lib.hs` file and library target by default,- `false` if you don't. If not specified it would be asked during each run of the `summoner`.-* `exe` – `true` if you want to create `app` folder with dummy `Main.hs` file and executable target by default,- `false` if you don't. If not specified it would be asked during each run of the `summoner`.-* `test` – `true` if you want to create `test` folder with dummy `Spec.hs` file and test target by default,- `false` if you don't. If not specified it would be asked during each run of the `summoner`.-* `bench` – `true` if you want to create `benchmark` folder with `Main.hs` file with [`gauge`](https://hackage.haskell.org/package/gauge)- library usage example by default,- `false` if you don't. If not specified it would be asked during each run of the `summoner`.-* `extensions` – List of the default extensions to add into `default-extensions` section in the `.cabal`.-* `warnings` – List of the default checks and warnings to add into `ghc-options` section in the `.cabal`.-* `stylish.*` — `stylish.file` to provide the absolute file path to the- `.stylish-haskell.yaml` file to use in the project. `stylish.url` to provide- the link to the `.stylish-haskell.yaml` file to use in the project. In case of- the absense or wrong path/link no `.stylish-haskell.yaml` file is created.-* `contributing.*` — `contributing.file` to provide the absolute file path to the- `CONTRIBUTING.md` file to use in the project. `contributing.url` to provide- the link to the `CONTRIBUTING.md` file to use in the project. In case of- the absense or wrong path/link no `CONTRIBUTING` file is created.+You can download binary directly [from GitHub releases](https://github.com/kowainik/summoner/releases). -###### Custom prelude options+After downloading binary, make it executable and copy it under convenient location, for example: -Should be specified inside `[prelude]` table.+```shell+chmod +x summon-cli-linux+mv summon-cli-linux ~/.local/bin/summon+``` -* `package` – Name of the package of the custom prelude you'd like to use in the project (doesn't work without `module` field).-* `module` – Name of the module of the custom prelude you'd like to use in the project (doesn't work without `package` field).+##### CLI: from Hackage/Stackage [↑](#structure) -###### Examples+Using `cabal`: -See an example of [the configuration for projects of the `Kowainik` organization](https://github.com/kowainik/org/blob/master/.summoner.toml).+```shell+cabal new-update+cabal new-install summoner+``` -By default, the `summoner` looks for the configuration file (`.summoner.toml`) in home directory.+Using `stack`: -The other way to specify some particular `.toml` file is `summon new PROJECTNAME --file FILEPATH` command.+```shell+stack install summoner+``` -##### CLI+##### CLI: from source [↑](#structure) +Fetch the repo using `cabal`:++```shell+cabal get -s summoner+```++or clone the directory from GitHub:++```shell+git clone https://github.com/kowainik/summoner.git+```++Step into the directory:++```haskell+cd summoner+```++Build and install using `cabal`:++```shell+cabal new-install summoner-cli:exe:summon+```++Build and install using `stack`:++```shell+stack install summoner:exe:summon+```++### Setup [↑](#structure)++You can turn on bash auto-completion by running the following command:++```shell+source <(summon --bash-completion-script `which summon`)+```++## Usage [↑](#structure)++To start `summon`ing projects nothing additional is required. However, to tweak your settings further, you can use additional configuration settings.+There are several options you can use to set particular configurations for new projects (in increasing order of priority):++1. Default configuration file (`~/.summoner.toml`).+2. Explicitly specified configuration file by `--file FILENAME` option (used instead of the default one if specified).+3. Options that are stated by CLI arguments.+4. User input. It could be+ * **TUI** – User data specified in the window of `summon-tui`.+ * **CLI** – Interactively inputted answers during execution of the `summon` command (for the options that were not specified on previous steps).++To cut a long story short, the configuration uses [Partial Options Monoid Pattern](https://medium.com/@jonathangfischoff/the-partial-options-monoid-pattern-31914a71fc67).++### File configuration [↑](#structure)++Here is the list of the options that can be configured to suit your needs. If options are not specified, they are asked interactively (or some sensible defaults are used).++| Field | Type | Description |+|------------------|---------|----------------------------------------------------------------------------------------------------------------------------------------------------------------------|+| `cabal` | Bool | Add Cabal support? |+| `stack` | Bool | Add Stack support? |+| `owner` | Text | GitHub login. |+| `fullName` | Text | Full name. |+| `email` | Text | E-mail address. |+| `license` | License | One of: `MIT`, `BSD2`, `BSD3`, `GPL-2`, `GPL-3`, `LGPL-2.1`, `LGPL-3`, `AGPL-3`, `Apache-2.0`, `MPL-2.0`, `None`. |+| `ghcVersions` | [GHC] | `summoner` uses default `GHC-8.4.4`. However, additionally you can specify other versions. For each version `x.y.z` the `stack-x.y.z.yaml` will be created. |+| `github` | Bool | Turn on `GitHub` integration by default? |+| `private` | Bool | Create private repository by default? (Ignored if `github = false`) |+| `travis` | Bool | Turn on `Travis` integration by default? (Ignored if `github = false`) |+| `appveyor` | Bool | Turn on `AppVeyor` integration by default? (Ignored if `github = false`) |+| `lib` | Bool | Create `src` folder with simple `ProjectName.hs` file and library target? |+| `exe` | Bool | Create `app` folder with simple `Main.hs` file and executable target? |+| `test` | Bool | Create `test` folder with simple `Spec.hs` file and test target? |+| `bench` | Bool | Create `benchmark` folder with `Main.hs` file with [`gauge`](https://hackage.haskell.org/package/gauge) library usage example? |+| `extensions` | [Text] | List of the default extensions to add into `default-extensions` section in the `.cabal`. |+| `warnings` | [Text] | List of the default checks and warnings to add into `ghc-options` section in the `.cabal`. |+| `stylish.*` | Text | `stylish.file` to provide the absolute file path OR `stylish.url` to download the `.stylish-haskell.yaml` file to use in the project. |+| `contributing.*` | Text | `contributing.file` to provide the absolute file path OR `contributing.url` download OR `contribuint.link` to link the `CONTRIBUTING.md` file to use in the project. |+|`[prelude]` | | |+| `package` | Text | The package name of the custom prelude you'd like to use in the project (doesn't work without `module` field). |+| `module` | Text | The module name of the custom prelude you'd like to use in the project (doesn't work without `package` field). |++See the example of [the configuration for projects of the `Kowainik` organization](https://github.com/kowainik/org/blob/master/.summoner.toml).++### Command line arguments [↑](#structure)+ Available commands: ```@@ -152,19 +355,25 @@ -v, --version Show summoner's version ``` -**`summon new`** command:+#### **summon new** command: [↑](#structure) ``` Usage:- summon new PROJECT_NAME [--cabal] [--stack] [--ignore-config]- [with [OPTIONS]] [without [OPTIONS]]+ summon new PROJECT_NAME [--ignore-config] [--no-upload] [--offline] [-f|--file FILENAME]+ [--cabal]+ [--stack] [--prelude-package PACKAGE_NAME] [--prelude-module MODULE_NAME]+ [with [OPTIONS]]+ [without [OPTIONS]] Available options: -h, --help Show this help text --ignore-config Ignore configuration file+ --no-upload Do not upload to GitHub. Special case of the '--offline' flag.+ --offline Offline mode: create project with 'All Rights Reserved' license+ and without uploading to GitHub. --cabal Cabal support for the project --stack Stack support for the project -f, --file FILENAME Path to the toml file with configurations. If not@@ -192,7 +401,7 @@ -b, --benchmark Benchmarks ``` -**`summon show`** command:+#### **summon show** command: [↑](#structure) ``` Usage:@@ -208,86 +417,129 @@ -h, --help Show this help text ``` -The options to be enabled/disabled can be specified while running the command.-If any of the applicable command options wasn't tagged as enabled/disabled, then-the question is asked during the work of the tool.--For example,+For example, the following command preconfigures the project settings with the custom prelude `relude`, included library, executable, test stanzas (but without benchmarks), creates a private repository on GitHub with the Travis CI and AppVeyor CI integrated. -```- summon new my-project with -letgcpw without -b --prelude-package relude --prelude-module Relude+```shell+summon new my-project with -letgcpw without -b --prelude-package relude --prelude-module Relude ``` -creates the fully functional project which uses custom prelude `relude`, contains-library, executable file, tests and create private repository on [github](https://github.com)-integrated with `Travis-CI`, `AppVeyor-CI`, but benchmarks won't be attached to this one.+### TUI [↑](#structure) -But when calling this command+#### TUI new command [↑](#structure) +++> **Section 1** – The main section where user inputs data or changes the configurations.++> **Section 2** – The structure of the project that is going to be created with the current configurations. This tree changes on-the-fly.++> **Section 3** – Hints, project status, or current errors in the configurations.++> **Section 4** – Useful hotkeys.++The TUI window opens with the pre-filled information received from a config file and command-line arguments. However, it's possible to change any field as per your needs.++In the screenshot you can see that you'll be given a few text fields to fill in or some checkboxes that represent boolean values of the configurations. To help you fill in the correct input, there are some ⓘ info messages in the `Status` section, which give additional details about the current field.++To help you navigate between the form fields here are the available hotkeys:++| Key | Action |+|-----------------------------------|--------------------------------------------------------------------------------------|+| <kbd>Esc</kbd> | Abort `summoner` |+| <kbd>Enter</kbd> | If input is valid go to the Confirm window |+| <kbd>Tab</kbd> | Change the focus to the next active field |+| <kbd>Shift</kbd> + <kbd>Tab</kbd> | Change the focus to the previous active field |+| <kbd>Space</kbd> | Enable/disable current checkbox or radio button |+| <kbd>Ctrl</kbd> + <kbd>d</kbd> | Delete the input of the current text field |+| <kbd>Ctrl</kbd> + <kbd>u</kbd> | Delete the input of the current text field from the cursor position to the beginning |+| <kbd>Ctrl</kbd> + <kbd>k</kbd> | Delete the input of the current text field from the cursor position to the end |+| <kbd>Ctrl</kbd> + <kbd>a</kbd> | Move the cursor to the beginning of the current input field |+| <kbd>Ctrl</kbd> + <kbd>e</kbd> | Move the cursor to the end of the current input field |+| <kbd>Up</kbd>/<kbd>Down</kbd> | Scroll license list when focused |++Note that the form should be valid in order to be able to go to the Confirm window. If there are some errors in the input, you could see details about these errors in the `Status` section of the form.++#### TUI show command [↑](#structure)++These commands display the list of supported GHC versions or Licenses. Also, when the license name is specified the window with the scrollable content of the License text is shown.++### CLI [↑](#structure)++#### CLI new command [↑](#structure)++In CLI mode of operation Summoner asks about every project setting. Most of the questions contain a default value, so you can press <kbd>Enter</kbd> to choose the default value.+If some option is specified via a configuration file or CLI arguments, then the question is skipped and the predefined value is used.++#### CLI show command [↑](#structure)++These commands display the list of supported GHC versions, or Licenses. Also, when the license name is specified, the content of the License is outputted to the terminal.++## For Developers [↑](#structure)++If you'd like to take part in the development processes, here are a few things to keep in mind:++* Summoner is a multi-package project which has two packages inside: `summoner-cli` and `summoner-tui`. We are supporting the same functionality in both of them, so, if it's possible, you should add/change the code in both of the packages.+* Summoner uses the custom prelude [`relude`](https://github.com/kowainik/relude).+* We are using the [Kowainik style guide](https://github.com/kowainik/org/blob/master/style-guide.md#haskell-style-guide).+* To sum up, [here is the Contributing guide](https://github.com/kowainik/org/blob/master/CONTRIBUTING.md#contributing-to-the-kowainik-repositories) we use across the repositories.+* This project is contributor-friendly, so be kind to other people working on the project.++### Build [↑](#structure)++To build the project you can use the following commands:++```shell=+cabal new-build all ```- summon new my-project++for Cabal and++```shell=+stack build ``` -the tool asks about every particular option, rather you'd like to have it-or not in your project.+for Stack. -## Features+### Test [↑](#structure) -If you're running the `summoner` with all options enabled a project with the following-hierarchy is created:+Summoner uses the golden tests technique for assuring the correctness of the generated files. For this purpose, we have [the `golden` folder](https://github.com/kowainik/summoner/tree/master/summoner-cli/test/golden) with two sample projects to test against. -```-project-name-├── app-│ └── Main.hs-├── benchmark-│ └── Main.hs-├── src-│ ├── ProjectName.hs-│ └── Prelude.hs-├── test-│ └── Spec.hs-├── CHANGELOG.md-├── LICENSE-├── project-name.cabal-├── README.md-├── Setup.hs-├── stack.yaml-├── appveyor.yml-├── .git-├── .gitignore-└── .travis.yml+To actually run tests you need to run:++```shell+cabal new-test all ``` -Moreover, a repository with one commit at master is added with enabled Travis CI for that.+or -## GHC options+```shell+stack test+``` -The `-Wall` option is added to every stanza.+### Run [↑](#structure) -The following warning checks are added by default to executable, tests and benchmark stanzas:+Building Summoner with the recommended method creates two executables: `summon` and `summon-tui`. To run the compiled executable you can use the following commands: - -threaded- -rtsopts- -with-rtsopts=-N+```shell+cabal new-exec summon -- SOME_COMMAND+cabal new-exec summon-tui -- SOME_COMMAND+``` -If warnings are not explicitly stated in the configuration file, then the-following ghc-options are added to all stanzas.+or - -Wincomplete-uni-patterns- -Wincomplete-record-updates- -Wcompat- -Widentities- -Wredundant-constraints (ghc >= 8.0)- -fhide-source-paths (ghc >= 8.2.2)- -Wmissing-export-lists (ghc >= 8.4.1)- -Wpartial-fields (ghc >= 8.4.1)+```shell+stack exec summon -- SOME_COMMAND+stack exec summon-tui -- SOME_COMMAND+``` -## Change log+## Changelog [↑](#structure) -[List of changes](CHANGELOG.md).+Each package has its own changelog: -## Acknowledgments+* [Summoner changelog](https://github.com/kowainik/summoner/blob/master/summoner-cli/CHANGELOG.md#changelog).+* [Summoner-TUI changelog](https://github.com/kowainik/summoner/blob/master/summoner-tui/CHANGELOG.md#changelog).++## Acknowledgments [↑](#structure) This project was inspired by [Aelve/new-hs](https://github.com/aelve/new-hs#readme), which is the tool with the same goal but it's only for creating cabal projects.
+ app/Cli.hs view
@@ -0,0 +1,8 @@+module Main where++import System.IO (hSetEncoding, stdout, utf8)++import Summoner (summonCli)++main :: IO ()+main = hSetEncoding stdout utf8 >> summonCli
− app/Main.hs
@@ -1,8 +0,0 @@-module Main where--import System.IO (hSetEncoding, utf8)--import Summoner (summon)--main :: IO ()-main = hSetEncoding stdout utf8 >> summon
src/Prelude.hs view
@@ -1,9 +1,19 @@--- | Uses @relude@ as a default prelude.+-- | Uses [relude](https://hackage.haskell.org/package/relude) as default Prelude. module Prelude ( module Relude , module Relude.Extra++ , endLine+ , memptyIfFalse ) where import Relude import Relude.Extra.Enum as Relude.Extra (inverseMap, universe)+import Relude.Extra.Validation as Relude.Extra++endLine :: Text+endLine = "\n"++memptyIfFalse :: Monoid m => Bool -> m -> m+memptyIfFalse p val = if p then val else mempty
src/Summoner.hs view
@@ -1,27 +1,16 @@ module Summoner- ( module Summoner.Ansi- , module Summoner.CLI- , module Summoner.Config- , module Summoner.Default- , module Summoner.License- , module Summoner.Process- , module Summoner.Project- , module Summoner.ProjectData- , module Summoner.Question- , module Summoner.Template- , module Summoner.Text- , module Summoner.Validation+ ( module Summoner ) where -import Summoner.Ansi-import Summoner.CLI-import Summoner.Config-import Summoner.Default-import Summoner.License-import Summoner.Process-import Summoner.Project-import Summoner.ProjectData-import Summoner.Question-import Summoner.Template-import Summoner.Text-import Summoner.Validation+import Summoner.Ansi as Summoner+import Summoner.CLI as Summoner+import Summoner.Config as Summoner+import Summoner.Default as Summoner+import Summoner.GhcVer as Summoner+import Summoner.License as Summoner+import Summoner.Process as Summoner+import Summoner.Project as Summoner+import Summoner.Question as Summoner+import Summoner.Settings as Summoner+import Summoner.Template as Summoner+import Summoner.Text as Summoner
src/Summoner/Ansi.hs view
@@ -26,11 +26,10 @@ ConsoleLayer (Foreground), SGR (..), setSGR, setSGRCode) import System.IO (hFlush) -------------------------------------------------------------------------------- Ansi-terminal-----------------------------------------------------------------------------+import qualified Data.Text as T --- Explicit flush ensures prompt messages are in the correct order on all systems.++-- | Explicit flush ensures prompt messages are in the correct order on all systems. putStrFlush :: Text -> IO () putStrFlush msg = do putText msg@@ -64,7 +63,7 @@ setColor Blue putStrFlush " -> " reset- getLine+ T.strip <$> getLine boldText :: Text -> IO () boldText message = bold >> putStrFlush message >> reset@@ -86,7 +85,7 @@ skipMessage = colorMessage Cyan blueCode, boldCode, redCode, resetCode :: String-redCode = setSGRCode [SetColor Foreground Vivid Red]-blueCode = setSGRCode [SetColor Foreground Vivid Blue]-boldCode = setSGRCode [SetConsoleIntensity BoldIntensity]+redCode = setSGRCode [SetColor Foreground Vivid Red]+blueCode = setSGRCode [SetColor Foreground Vivid Blue]+boldCode = setSGRCode [SetConsoleIntensity BoldIntensity] resetCode = setSGRCode [Reset]
src/Summoner/CLI.hs view
@@ -6,10 +6,20 @@ -- | This module contains functions and data types to parse CLI inputs. module Summoner.CLI- ( summon+ ( -- * CLI data types+ Command (..)+ , NewOpts (..)+ , ShowOpts (..)++ -- * Functions to parse CLI arguments and run @summoner@+ , summon+ , summonCli++ -- * Common helper functions+ , getFinalConfig ) where -import Data.Version (showVersion)+import Data.Version (Version, showVersion) import Development.GitRev (gitCommitDate, gitDirty, gitHash) import NeatInterpolation (text) import Options.Applicative (Parser, ParserInfo, command, execParser, flag, fullDesc, help, helper,@@ -18,75 +28,110 @@ import Options.Applicative.Help.Chunk (stringChunk) import System.Directory (doesFileExist) -import Paths_summoner (version)-import Summoner.Ansi (Color (Green), beautyPrint, blueCode, bold, boldCode, errorMessage,- infoMessage, redCode, resetCode, setColor, warningMessage)-import Summoner.Config (ConfigP (..), PartialConfig, defaultConfig, finalise, loadFileConfig)+import Summoner.Ansi (blueCode, boldCode, errorMessage, infoMessage, redCode, resetCode,+ warningMessage)+import Summoner.Config (Config, ConfigP (..), PartialConfig, defaultConfig, finalise,+ loadFileConfig) import Summoner.Decision (Decision (..))-import Summoner.Default (defaultConfigFile, endLine)+import Summoner.Default (defaultConfigFile) import Summoner.GhcVer (GhcVer, showGhcVer)-import Summoner.License (License (..), LicenseName (..), fetchLicense, parseLicenseName)+import Summoner.License (License (..), LicenseName (..), fetchLicense, parseLicenseName,+ showLicenseWithDesc) import Summoner.Project (generateProject)-import Summoner.ProjectData (CustomPrelude (..))-import Summoner.Validation (Validation (..))+import Summoner.Settings (CustomPrelude (..)) import qualified Data.Text as T+import qualified Paths_summoner as Meta (version) ------------------------------------------------------------------------------- CLI----------------------------------------------------------------------------- -summon :: IO ()-summon = execParser prsr >>= runCommand+-- | Main function that parses @CLI@ commands and runs them using given+-- 'Command' handler.+summon :: Version -> (Command -> IO ()) -> IO ()+summon version performCommand = execParser (cliParser version) >>= performCommand --- | Run 'summoner' with cli command-runCommand :: Command -> IO ()-runCommand = \case+-- | Runs @summoner@ in CLI mode.+summonCli :: IO ()+summonCli = summon Meta.version runCliCommand++-- | Run 'summoner' with @CLI@ command+runCliCommand :: Command -> IO ()+runCliCommand = \case New opts -> runNew opts ShowInfo opts -> runShow opts +{- | Runs @show@ command.++@+Usage:+ summon show COMMAND+ Show supported licenses or ghc versions++Available commands:+ ghc Show available ghc versions+ license Show available licenses+ license [LICENSE_NAME] Show specific license text+@++-} runShow :: ShowOpts -> IO () runShow = \case- -- show list of all available GHC versions- GhcList -> showBulletList @GhcVer showGhcVer (reverse universe)- -- show a list of all available licenses- LicenseList Nothing -> showBulletList @LicenseName show universe- -- show a specific license- LicenseList (Just name) ->- case parseLicenseName (toText name) of- Nothing -> do- errorMessage "This wasn't a valid choice."- infoMessage "Here is the list of supported licenses:"- showBulletList @LicenseName show universe- -- get and show a license`s text- Just licenseName -> do- fetchedLicense <- fetchLicense licenseName- putTextLn $ unLicense fetchedLicense+ -- show list of all available GHC versions+ GhcList -> showBulletList @GhcVer showGhcVer (reverse universe)+ -- show a list of all available licenses+ LicenseList Nothing -> showBulletList @LicenseName showLicenseWithDesc universe+ -- show a specific license+ LicenseList (Just name) ->+ case parseLicenseName (toText name) of+ Nothing -> do+ errorMessage "This wasn't a valid choice."+ infoMessage "Here is the list of supported licenses:"+ showBulletList @LicenseName show universe+ -- get and show a license`s text+ Just licenseName -> do+ fetchedLicense <- fetchLicense licenseName+ putTextLn $ unLicense fetchedLicense where showBulletList :: (a -> Text) -> [a] -> IO () showBulletList showT = mapM_ (infoMessage . T.append "➤ " . showT) +{- | Runs @new@ command.++@+Usage:+ summon new PROJECT_NAME [--ignore-config] [--no-upload] [--offline]+ [-f|--file FILENAME]+ [--cabal]+ [--stack]+ [--prelude-package PACKAGE_NAME]+ [--prelude-module MODULE_NAME]+ [with [OPTIONS]]+ [without [OPTIONS]]+@++-} runNew :: NewOpts -> IO ()-runNew NewOpts{..} = do+runNew newOpts@NewOpts{..} = do+ -- get the final config+ finalConfig <- getFinalConfig newOpts+ -- Generate the project.+ generateProject newOptsNoUpload newOptsOffline newOptsProjectName finalConfig++-- | By the given 'NewOpts' return the final configurations.+getFinalConfig :: NewOpts -> IO Config+getFinalConfig NewOpts{..} = do -- read config from file- fileConfig <- readFileConfig ignoreFile maybeFile+ fileConfig <- readFileConfig newOptsIgnoreFile newOptsConfigFile -- union all possible configs- let unionConfig = defaultConfig <> fileConfig <> cliConfig+ let unionConfig = defaultConfig <> fileConfig <> newOptsCliConfig -- get the final config- finalConfig <- case finalise unionConfig of- Success c -> pure c- Failure msgs -> do- for_ msgs errorMessage- exitFailure-- -- Generate the project.- generateProject projectName finalConfig-- -- print result- beautyPrint [bold, setColor Green] "\nJob's done\n"+ case finalise unionConfig of+ Success c -> pure c+ Failure msgs -> for_ msgs errorMessage >> exitFailure +-- | Reads and parses the given config file. If no file is provided the default+-- configuration returned. readFileConfig :: Bool -> Maybe FilePath -> IO PartialConfig readFileConfig ignoreFile maybeFile = if ignoreFile then pure mempty else do (isDefault, file) <- case maybeFile of@@ -119,10 +164,12 @@ -- | Options parsed with @new@ command data NewOpts = NewOpts- { projectName :: Text -- ^ project name- , ignoreFile :: Bool -- ^ ignore all config files if 'True'- , maybeFile :: Maybe FilePath -- ^ file with custom configuration- , cliConfig :: PartialConfig -- ^ config gathered during CLI+ { newOptsProjectName :: Text -- ^ project name+ , newOptsIgnoreFile :: Bool -- ^ ignore all config files if 'True'+ , newOptsNoUpload :: Bool -- ^ don't upload to github+ , newOptsOffline :: Bool -- ^ Offline mode+ , newOptsConfigFile :: Maybe FilePath -- ^ file with custom configuration+ , newOptsCliConfig :: PartialConfig -- ^ config gathered during CLI } -- | Commands parsed with @show@ command@@ -133,21 +180,23 @@ ---------------------------------------------------------------------------- -- | Main parser of the app.-prsr :: ParserInfo Command-prsr = modifyHeader+cliParser :: Version -> ParserInfo Command+cliParser version = modifyHeader $ modifyFooter- $ info ( helper <*> versionP <*> summonerP )+ $ info ( helper <*> versionP version <*> summonerP ) $ fullDesc <> progDesc "Set up your own Haskell project" -versionP :: Parser (a -> a)-versionP = infoOption summonerVersion+versionP :: Version -> Parser (a -> a)+versionP version = infoOption (summonerVersion version) $ long "version" <> short 'v' <> help "Show summoner's version" -summonerVersion :: String-summonerVersion = toString $ intercalate "\n" $ [sVersion, sHash, sDate] ++ [sDirty | $(gitDirty)]+summonerVersion :: Version -> String+summonerVersion version = toString+ $ intercalate "\n"+ $ [sVersion, sHash, sDate] ++ [sDirty | $(gitDirty)] where sVersion = blueCode <> boldCode <> "Summoner " <> "v" <> showVersion version <> resetCode sHash = " ➤ " <> blueCode <> boldCode <> "Git revision: " <> resetCode <> $(gitHash)@@ -182,22 +231,27 @@ -- | Parses options of the @new@ command. newP :: Parser Command newP = do- projectName <- strArgument (metavar "PROJECT_NAME")- ignoreFile <- ignoreFileP- cabal <- cabalP- stack <- stackP- with <- optional withP- without <- optional withoutP- file <- optional fileP+ newOptsProjectName <- strArgument (metavar "PROJECT_NAME")+ newOptsIgnoreFile <- ignoreFileP+ newOptsNoUpload <- noUploadP+ newOptsOffline <- offlineP+ newOptsConfigFile <- optional fileP+ cabal <- cabalP+ stack <- stackP preludePack <- optional preludePackP preludeMod <- optional preludeModP+ with <- optional withP+ without <- optional withoutP - pure $ New $ NewOpts projectName ignoreFile file- $ (maybeToMonoid $ with <> without)- { cPrelude = Last $ Prelude <$> preludePack <*> preludeMod+ pure $ New $ NewOpts+ { newOptsNoUpload = newOptsNoUpload || newOptsOffline+ , newOptsCliConfig = (maybeToMonoid $ with <> without)+ { cPrelude = Last $ CustomPrelude <$> preludePack <*> preludeMod , cCabal = cabal , cStack = stack }+ , ..+ } targetsP :: Decision -> Parser PartialConfig targetsP d = do@@ -282,6 +336,14 @@ ignoreFileP :: Parser Bool ignoreFileP = switch $ long "ignore-config" <> help "Ignore configuration file"++noUploadP :: Parser Bool+noUploadP = switch $ long "no-upload" <> help "Do not upload to GitHub. Special case of the '--offline' flag."++offlineP :: Parser Bool+offlineP = switch+ $ long "offline"+ <> help "Offline mode: create project with 'All Rights Reserved' license and without uploading to GitHub." fileP :: Parser FilePath fileP = strOption
src/Summoner/Config.hs view
@@ -26,17 +26,18 @@ import Data.List (lookup) import Generics.Deriving.Monoid (GMonoid, gmemptydefault) import Generics.Deriving.Semigroup (GSemigroup, gsappenddefault)-import Toml (AnyValue (..), BiMap (..), BiToml, Bijection (..), Key, dimap, (.=))+import Toml (BiMap (..), Key, TomlCodec, (.=)) import Summoner.Decision (Decision (..)) import Summoner.GhcVer (GhcVer (..), parseGhcVer, showGhcVer) import Summoner.License (LicenseName (..), parseLicenseName)-import Summoner.ProjectData (CustomPrelude (..))+import Summoner.Settings (CustomPrelude (..), customPreludeT) import Summoner.Source (Source, sourceT)-import Summoner.Validation (Validation (..)) import qualified Toml ++-- | The phase of the configurations. data Phase = Partial | Final -- | Potentially incomplete configuration.@@ -128,7 +129,7 @@ } -- | Identifies how to read 'Config' data from the @.toml@ file.-configT :: BiToml PartialConfig+configT :: TomlCodec PartialConfig configT = Config <$> lastT Toml.text "owner" .= cOwner <*> lastT Toml.text "fullName" .= cFullName@@ -145,44 +146,29 @@ <*> decision "exe" .= cExe <*> decision "test" .= cTest <*> decision "bench" .= cBench- <*> lastT (Toml.table preludeT) "prelude" .= cPrelude- <*> textArr "extensions" .= cExtensions- <*> textArr "warnings" .= cWarnings- <*> wrapLastT (maybeSourceT "stylish") .= cStylish- <*> wrapLastT (maybeSourceT "contributing") .= cContributing+ <*> lastT preludeT "prelude" .= cPrelude+ <*> textArr "extensions" .= cExtensions+ <*> textArr "warnings" .= cWarnings+ <*> lastT sourceT "stylish" .= cStylish+ <*> lastT sourceT "contributing" .= cContributing where- wrapLastT :: BiToml (Maybe a) -> BiToml (Last a)- wrapLastT = Toml.dimap getLast Last-- maybeSourceT :: Key -> BiToml (Maybe Source)- maybeSourceT key = dimaybeT (sourceT key)-- dimaybeT :: BiToml a -> BiToml (Maybe a)- dimaybeT bi = Bijection- { biRead = optional (biRead bi)- , biWrite = traverse (biWrite bi)- }-- lastT :: (Key -> BiToml a) -> Key -> BiToml (Last a)- lastT = Toml.wrapper . Toml.maybeT+ lastT :: (Key -> TomlCodec a) -> Key -> TomlCodec (Last a)+ lastT codec = Toml.dimap getLast Last . Toml.dioptional . codec - _GhcVer :: BiMap AnyValue GhcVer- _GhcVer = BiMap- { forward = \(AnyValue t) -> Toml.matchText t >>= parseGhcVer- , backward = Just . AnyValue . Toml.Text . showGhcVer- }+ _GhcVer :: BiMap GhcVer Toml.AnyValue+ _GhcVer = Toml._TextBy showGhcVer parseGhcVer - ghcVerArr :: Key -> BiToml [GhcVer]+ ghcVerArr :: Key -> TomlCodec [GhcVer] ghcVerArr = Toml.arrayOf _GhcVer - license :: Key -> BiToml LicenseName+ license :: Key -> TomlCodec LicenseName license = Toml.mdimap show parseLicenseName . Toml.text - textArr :: Key -> BiToml [Text]- textArr = dimap Just maybeToMonoid . Toml.maybeT (Toml.arrayOf Toml._Text)+ textArr :: Key -> TomlCodec [Text]+ textArr = Toml.dimap Just maybeToMonoid . Toml.dioptional . Toml.arrayOf Toml._Text - decision :: Key -> BiToml Decision- decision = dimap fromDecision toDecision . Toml.maybeT Toml.bool+ decision :: Key -> TomlCodec Decision+ decision = Toml.dimap fromDecision toDecision . Toml.dioptional . Toml.bool decisionMaybe :: [(Decision, Maybe Bool)] decisionMaybe = [ (Idk, Nothing)@@ -196,10 +182,9 @@ toDecision :: Maybe Bool -> Decision toDecision m = fromMaybe (error "Impossible") $ lookup m $ map swap decisionMaybe - preludeT :: BiToml CustomPrelude- preludeT = Prelude- <$> Toml.text "package" .= cpPackage- <*> Toml.text "module" .= cpModule+ preludeT :: Key -> TomlCodec CustomPrelude+ preludeT = Toml.table customPreludeT+ -- | Make sure that all the required configurations options were specified. finalise :: PartialConfig -> Validation [Text] Config
src/Summoner/Decision.hs view
@@ -8,7 +8,7 @@ import Generics.Deriving.Monoid (GMonoid (..)) import Generics.Deriving.Semigroup (GSemigroup (..)) -import Summoner.Question (chooseYesNoBool, falseMessage, trueMessage)+import Summoner.Question (YesNoPrompt (..), chooseYesNoBool, falseMessage, trueMessage) -- | Used for detecting the user decision during CLI input.@@ -32,8 +32,8 @@ gmempty = mempty gmappend = (<>) -decisionToBool :: Decision -> Text -> IO Bool-decisionToBool decision target = case decision of- Yes -> trueMessage target- Nop -> falseMessage target+decisionToBool :: Decision -> YesNoPrompt -> IO Bool+decisionToBool decision target@YesNoPrompt {..} = case decision of+ Yes -> trueMessage yesNoTarget+ Nop -> falseMessage yesNoTarget Idk -> chooseYesNoBool target
src/Summoner/Default.hs view
@@ -4,8 +4,8 @@ ( defaultGHC , defaultTomlFile , defaultConfigFile+ , defaultDescription , currentYear- , endLine ) where import Data.Time (getCurrentTime, toGregorian, utctDay)@@ -22,17 +22,17 @@ defaultGHC :: GhcVer defaultGHC = maxBound -defaultTomlFile :: String+defaultTomlFile :: FilePath defaultTomlFile = ".summoner.toml" defaultConfigFile :: IO FilePath defaultConfigFile = (</> defaultTomlFile) <$> getHomeDirectory +defaultDescription :: Text+defaultDescription = "See README for more info"+ currentYear :: IO Text currentYear = do now <- getCurrentTime let (year, _, _) = toGregorian $ utctDay now pure $ show year--endLine :: Text-endLine = "\n"
src/Summoner/GhcVer.hs view
@@ -1,11 +1,18 @@ module Summoner.GhcVer ( GhcVer (..)+ , Pvp (..) , showGhcVer , parseGhcVer , latestLts , baseVer+ , cabalBaseVersions ) where +import Data.List (maximum, minimum)++import qualified Text.Show as Show++ -- | Represents some selected set of GHC versions. data GhcVer = Ghc7103@@ -13,6 +20,7 @@ | Ghc802 | Ghc822 | Ghc843+ | Ghc844 deriving (Eq, Ord, Show, Enum, Bounded) -- | Converts 'GhcVer' into dot-separated string.@@ -23,6 +31,7 @@ Ghc802 -> "8.0.2" Ghc822 -> "8.2.2" Ghc843 -> "8.4.3"+ Ghc844 -> "8.4.4" parseGhcVer :: Text -> Maybe GhcVer parseGhcVer = inverseMap showGhcVer@@ -34,13 +43,49 @@ Ghc801 -> "7.24" Ghc802 -> "9.21" Ghc822 -> "11.22"- Ghc843 -> "12.9"+ Ghc843 -> "12.14"+ Ghc844 -> "12.20" --- | Returns base version by 'GhcVer'.+-- | Represents PVP versioning (4 numbers).+data Pvp = Pvp+ { pvpFirst :: Int+ , pvpSecond :: Int+ , pvpThird :: Int+ , pvpFourth :: Int+ }++-- | Show PVP version in a standard way: @1.2.3.4@+instance Show Pvp where+ show (Pvp a b c d) = intercalate "." $ map Show.show [a, b, c, d]++-- | Returns base version by 'GhcVer' as 'Pvp'.+baseVerPvp :: GhcVer -> Pvp+baseVerPvp = \case+ Ghc7103 -> Pvp 4 8 0 2+ Ghc801 -> Pvp 4 9 0 0+ Ghc802 -> Pvp 4 9 1 0+ Ghc822 -> Pvp 4 10 1 0+ Ghc843 -> Pvp 4 11 1 0+ Ghc844 -> Pvp 4 11 1 0++-- | Returns corresponding @base@ version of the given GHC version. baseVer :: GhcVer -> Text-baseVer = \case- Ghc7103 -> "4.8.0.2"- Ghc801 -> "4.9.0.0"- Ghc802 -> "4.9.1.0"- Ghc822 -> "4.10.1.0"- Ghc843 -> "4.11.1.0"+baseVer = show . baseVerPvp++{- | Returns the @base@ bounds for the list of the given GHC versions.++>>> cabalBaseVersions [Ghc844]+"^>= 4.11.1.0"++>>> cabalBaseVersions [Ghc802, Ghc822, Ghc844]+">= 4.9.0.0 && < 4.12"++-}+cabalBaseVersions :: [GhcVer] -> Text+cabalBaseVersions [] = ""+cabalBaseVersions [v] = "^>= " <> baseVer v+cabalBaseVersions ghcs = ">= " <> baseVer (minimum ghcs) <> " && < " <> upperBound+ where+ upperBound :: Text+ upperBound = let Pvp{..} = baseVerPvp $ maximum ghcs in+ show pvpFirst <> "." <> show (pvpSecond + 1)
src/Summoner/License.hs view
@@ -1,10 +1,16 @@+-- | Data types that represent license names and license content and functions+-- to work with them.+ module Summoner.License ( LicenseName(..) , License(..)+ , cabalLicense , customizeLicense , githubLicenseQueryNames , parseLicenseName , fetchLicense+ , licenseShortDesc+ , showLicenseWithDesc ) where import Data.Aeson (FromJSON (..), decodeStrict, withObject, (.:))@@ -14,10 +20,8 @@ import qualified Data.Text as T import qualified Text.Show as TS -------------------------------------------------------------------------------- License----------------------------------------------------------------------------- +-- | Licenses supported by @summoner@. data LicenseName = MIT | BSD2@@ -29,6 +33,7 @@ | AGPL3 | Apache20 | MPL20+ | None deriving (Eq, Ord, Enum, Bounded, Generic) instance Show LicenseName where@@ -42,6 +47,7 @@ show AGPL3 = "AGPL-3" show Apache20 = "Apache-2.0" show MPL20 = "MPL-2.0"+ show None = "None" newtype License = License { unLicense :: Text } deriving (IsString, Show, Generic)@@ -49,6 +55,12 @@ instance FromJSON License where parseJSON = withObject "License" $ \o -> License <$> o .: "body" +-- | As it will be shown in the @cabal@ file.+cabalLicense :: LicenseName -> Text+cabalLicense None = "AllRightsReserved"+cabalLicense l = show l++-- | Used for downloading the license text form @Github@. githubLicenseQueryNames :: LicenseName -> Text githubLicenseQueryNames = \case MIT -> "mit"@@ -61,10 +73,12 @@ AGPL3 -> "agpl-3.0" Apache20 -> "apache-2.0" MPL20 -> "mpl-2.0"+ None -> "none" parseLicenseName :: Text -> Maybe LicenseName parseLicenseName = inverseMap show +-- | Replaces name/year placeholders with the actual data. customizeLicense :: LicenseName -> License -> Text -> Text -> License customizeLicense l license@(License licenseText) nm year | l `elem` [MIT, BSD2, BSD3] = License updateLicenseText@@ -78,8 +92,30 @@ in beforeY <> year <> beforeN <> nm <> afterN fetchLicense :: LicenseName -> IO License+fetchLicense None = pure $ License $ licenseShortDesc None fetchLicense name = do let licenseLink = "https://api.github.com/licenses/" <> githubLicenseQueryNames name licenseJson <- readProcess "curl" [ toString licenseLink, "-H", "Accept: application/vnd.github.drax-preview+json"] "" pure $ fromMaybe (error "Broken predefined license list") (decodeStrict $ pack licenseJson)++-- | Show short information for the 'LicenseName'.+licenseShortDesc :: LicenseName -> Text+licenseShortDesc = \case+ MIT -> "MIT license"+ BSD2 -> "2-clause BSD license"+ BSD3 -> "3-clause BSD license"+ GPL2 -> "GNU General Public License, version 2"+ GPL3 -> "GNU General Public License, version 3"+ LGPL21 -> "GNU Lesser General Public License, version 2.1"+ LGPL3 -> "GNU Lesser General Public License, version 3"+ AGPL3 -> "GNU Affero General Public License, version 3"+ Apache20 -> "Apache License, version 2.0"+ MPL20 -> "Mozilla Public License, version 2.0."+ None -> "License file won't be added. Explicitly 'All Rights Reserved', eg \+ \for proprietary software. The package may not be legally modified or \+ \redistributed by anyone but the rightsholder"++-- | Show license name along with its short description.+showLicenseWithDesc :: LicenseName -> Text+showLicenseWithDesc l = show l <> ": " <> licenseShortDesc l
src/Summoner/Process.hs view
@@ -14,18 +14,15 @@ import Summoner.Ansi (errorMessage) -------------------------------------------------------------------------------- Commands----------------------------------------------------------------------------- --- This is needed to be able to call commands by writing strings.+-- | This is needed to be able to call commands by writing strings. instance (a ~ Text, b ~ ()) => IsString ([a] -> IO b) where fromString cmd args = do let cmdStr = showCommandForUser cmd (map toString args) putStrLn $ "⚙ " ++ cmdStr callCommand cmdStr --- Delete file, but just print a message if delete fails and continue instead of raising an error.+-- | Delete file, but just print a message if delete fails and continue instead of raising an error. deleteFile :: FilePath -> IO () deleteFile file = removeFile file `catch` printError where
src/Summoner/Project.hs view
@@ -1,72 +1,93 @@ {-# LANGUAGE QuasiQuotes #-} --- | This module introduces functional for project creation.+-- | This module introduces functions for the project creation. module Summoner.Project ( generateProject+ , initializeProject ) where import NeatInterpolation (text) import System.Directory (setCurrentDirectory) -import Summoner.Ansi (errorMessage, infoMessage, successMessage)+import Summoner.Ansi (Color (Green), beautyPrint, bold, errorMessage, infoMessage, setColor,+ successMessage) import Summoner.Config (Config, ConfigP (..)) import Summoner.Decision (Decision (..), decisionToBool)-import Summoner.Default (currentYear, defaultGHC)+import Summoner.Default (currentYear, defaultDescription, defaultGHC) import Summoner.GhcVer (parseGhcVer, showGhcVer)-import Summoner.License (customizeLicense, fetchLicense, parseLicenseName)+import Summoner.License (LicenseName (..), customizeLicense, fetchLicense, licenseShortDesc,+ parseLicenseName) import Summoner.Process ()-import Summoner.ProjectData (CustomPrelude (..), ProjectData (..))-import Summoner.Question (checkUniqueName, choose, chooseYesNo, falseMessage, query, queryDef,- queryManyRepeatOnFail, targetMessageWithText, trueMessage)+import Summoner.Question (YesNoPrompt (..), checkUniqueName, choose, chooseYesNo, falseMessage,+ mkDefaultYesNoPrompt, query, queryDef, queryManyRepeatOnFail,+ queryNotNull, targetMessageWithText, trueMessage)+import Summoner.Settings (CustomPrelude (..), Settings (..)) import Summoner.Source (fetchSource) import Summoner.Template (createProjectTemplate) import Summoner.Text (intercalateMap, packageToModule)-import Summoner.Tree (showTree, traverseTree)+import Summoner.Tree (showBoldTree, traverseTree) + -- | Generate the project.-generateProject :: Text -> Config -> IO ()-generateProject projectName Config{..} = do- repo <- checkUniqueName projectName+generateProject+ :: Bool -- ^ @noUpload@ option (to not upload to @Github@).+ -> Bool -- ^ @offline@ mode option+ -> Text -- ^ Given project name.+ -> Config -- ^ Given configurations.+ -> IO ()+generateProject settingsNoUpload isOffline projectName Config{..} = do+ settingsRepo <- checkUniqueName projectName -- decide cabal stack or both- (cabal, stack) <- getCabalStack (cCabal, cStack)+ (settingsCabal, settingsStack) <- getCabalStack (cCabal, cStack) - owner <- queryDef "Repository owner: " cOwner- description <- query "Short project description: "- nm <- queryDef "Author: " cFullName- email <- queryDef "Maintainer e-mail: " cEmail+ settingsOwner <- queryDef "Repository owner: " cOwner+ settingsDescription <- queryDef "Short project description: " defaultDescription+ settingsFullName <- queryDef "Author: " cFullName+ settingsEmail <- queryDef "Maintainer e-mail: " cEmail+ putText categoryText- category <- query "Category: "- licenseName <- choose parseLicenseName "License: " $ ordNub (cLicense : universe)+ settingsCategories <- query "Category: " + putText licenseText+ settingsLicenseName <- if isOffline+ then None <$ infoMessage "'AllRightsReserved' license is used in offline mode"+ else choose parseLicenseName "License: " $ ordNub (cLicense : universe)+ -- License creation- fetchedLicense <- fetchLicense licenseName- year <- currentYear- let licenseText = customizeLicense licenseName fetchedLicense nm year+ fetchedLicense <- fetchLicense settingsLicenseName+ settingsYear <- currentYear+ let settingsLicenseText = customizeLicense+ settingsLicenseName+ fetchedLicense+ settingsFullName+ settingsYear - -- Library/Executable/Tests/Benchmarks flags- github <- decisionToBool cGitHub "GitHub integration"- travis <- ifGithub github "Travis CI integration" cTravis- appVey <- ifGithub (stack && github) "AppVeyor CI integration" cAppVey- privat <- ifGithub github "private repository" cPrivate- isLib <- decisionToBool cLib "library target"- isExe <- let target = "executable target" in- if isLib- then decisionToBool cExe target- else trueMessage target- test <- decisionToBool cTest "tests"- bench <- decisionToBool cBench "benchmarks"- prelude <- if isLib then getPrelude else pure Nothing- let base = case prelude of+ settingsGitHub <- decisionToBool cGitHub+ (YesNoPrompt "GitHub integration" "Do you want to create a GitHub repository?")+ settingsPrivate <- decisionIf+ (settingsGitHub && not settingsNoUpload)+ (YesNoPrompt "private repository" "Create as a private repository (Requires a GitHub private repo plan)?")+ cPrivate+ settingsTravis <- decisionIf settingsGitHub (mkDefaultYesNoPrompt "Travis CI integration") cTravis+ settingsAppVeyor <- decisionIf (settingsStack && settingsGitHub) (mkDefaultYesNoPrompt "AppVeyor CI integration") cAppVey+ settingsIsLib <- decisionToBool cLib (mkDefaultYesNoPrompt "library target")+ settingsIsExe <- let target = "executable target" in+ if settingsIsLib+ then decisionToBool cExe (mkDefaultYesNoPrompt target)+ else trueMessage target+ settingsTest <- decisionToBool cTest (mkDefaultYesNoPrompt "tests")+ settingsBench <- decisionToBool cBench (mkDefaultYesNoPrompt "benchmarks")+ settingsPrelude <- if settingsIsLib then getPrelude else pure Nothing+ let settingsBaseType = case settingsPrelude of Nothing -> "base" Just _ -> "base-noprelude" - let extensions = cExtensions-- let warnings = cWarnings+ let settingsExtensions = cExtensions+ let settingsWarnings = cWarnings putTextLn $ "The project will be created with the latest resolver for default GHC-" <> showGhcVer defaultGHC- testedVersions <- sortNub . (defaultGHC :) <$> case cGhcVer of+ settingsTestedVersions <- sortNub . (defaultGHC :) <$> case cGhcVer of [] -> do putTextLn "Additionally you can specify versions of GHC to test with (space-separated): " infoMessage $ "Supported by 'summoner' GHCs: " <> intercalateMap " " showGhcVer universe@@ -75,47 +96,20 @@ putTextLn $ "Also these GHC versions will be added: " <> intercalateMap " " showGhcVer vers pure vers - stylish <- case getLast cStylish of- Nothing -> pure Nothing- Just s -> fetchSource s-- contributing <- case getLast cContributing of- Nothing -> pure Nothing- Just s -> fetchSource s+ let fetchLast = maybe (pure Nothing) (fetchSource isOffline) . getLast+ settingsStylish <- fetchLast cStylish+ settingsContributing <- fetchLast cContributing -- Create project data from all variables in scope- let projectData = ProjectData{..}-- -- create stack project- createProjectDirectory projectData- -- create github repository and commit- when github $ doGithubCommands projectData privat-+ -- and make a project from it.+ initializeProject Settings{..} where- ifGithub :: Bool -> Text -> Decision -> IO Bool- ifGithub github target decision = if github- then decisionToBool decision target- else falseMessage target+ decisionIf :: Bool -> YesNoPrompt -> Decision -> IO Bool+ decisionIf p ynPrompt decision = if p+ then decisionToBool decision ynPrompt+ else falseMessage (yesNoTarget ynPrompt) - createProjectDirectory :: ProjectData -> IO ()- createProjectDirectory projectData@ProjectData{..} = do- let tree = createProjectTemplate projectData- traverseTree tree- successMessage "\nThe project with the following structure has been created:"- putTextLn $ showTree tree- setCurrentDirectory (toString repo) - doGithubCommands :: ProjectData -> Bool -> IO ()- doGithubCommands ProjectData{..} private = do- -- Create the repository on Github.- "git" ["init"]- "hub" $ ["create", "-d", description, owner <> "/" <> repo]- ++ ["-p" | private] -- creates private repository if asked so.- -- Make a commit and push it.- "git" ["add", "."]- "git" ["commit", "-m", "Create the project"]- "git" ["push", "-u", "origin", "master"]- categoryText :: Text categoryText = [text|@@ -136,26 +130,34 @@ |] + licenseText :: Text+ licenseText = "List of licenses to choose from:\n\n"+ <> unlines (map showShort $ universe @LicenseName)+ <> "\n"+ where+ showShort :: LicenseName -> Text+ showShort l = " * " <> show l <> ": " <> licenseShortDesc l+ getPrelude :: IO (Maybe CustomPrelude) getPrelude = case cPrelude of Last Nothing -> do let yesDo, noDo :: IO (Maybe CustomPrelude) yesDo = do- p <- query "Custom prelude package: "+ p <- queryNotNull "Custom prelude package: " m <- queryDef "Custom prelude module: " (packageToModule p) successMessage $ "Custom prelude " <> p <> " will be used in the project"- pure $ Just $ Prelude p m+ pure $ Just $ CustomPrelude p m noDo = pure Nothing- chooseYesNo "custom prelude" yesDo noDo- Last prelude@(Just (Prelude p _)) ->+ chooseYesNo (mkDefaultYesNoPrompt "custom prelude") yesDo noDo+ Last prelude@(Just (CustomPrelude p _)) -> prelude <$ successMessage ("Custom prelude " <> p <> " will be used in the project") -- get what build tool to use in the project -- If user chose only one during CLI, we assume to use only that one. getCabalStack :: (Decision, Decision) -> IO (Bool, Bool) getCabalStack = \case- (Idk, Idk) -> decisionToBool cCabal "cabal" >>= \c ->- if c then decisionToBool cStack "stack" >>= \s -> pure (c, s)+ (Idk, Idk) -> decisionToBool cCabal (mkDefaultYesNoPrompt "cabal") >>= \c ->+ if c then decisionToBool cStack (mkDefaultYesNoPrompt "stack") >>= \s -> pure (c, s) else stackMsg True >> pure (False, True) (Nop, Nop) -> errorMessage "Neither cabal nor stack was chosen" >> exitFailure (Yes, Yes) -> output (True, True)@@ -169,3 +171,33 @@ cabalMsg c = targetMessageWithText c "Cabal" "used in this project" stackMsg c = targetMessageWithText c "Stack" "used in this project"++-- | Creates the directory and run GitHub commands.+initializeProject :: Settings -> IO ()+initializeProject settings@Settings{..} = do+ createProjectDirectory settings+ when settingsGitHub $ doGithubCommands settings+ beautyPrint [bold, setColor Green] "\nJob's done\n"+++-- | From the given 'Settings' creates the project.+createProjectDirectory :: Settings -> IO ()+createProjectDirectory settings@Settings{..} = do+ let tree = createProjectTemplate settings+ traverseTree tree+ successMessage "\nThe project with the following structure has been created:"+ putTextLn $ showBoldTree tree+ setCurrentDirectory (toString settingsRepo)++-- | Init, commit and push repository to GitHub.+doGithubCommands :: Settings -> IO ()+doGithubCommands Settings{..} = do+ -- Create git repostitory and do a commit.+ "git" ["init"]+ "git" ["add", "."]+ "git" ["commit", "-m", "Create the project"]+ unless settingsNoUpload $ do+ "hub" $ ["create", "-d", settingsDescription, settingsOwner <> "/" <> settingsRepo]+ ++ ["-p" | settingsPrivate] -- Create private repository if asked so+ -- Upload repository to GitHub.+ "git" ["push", "-u", "origin", "master"]
− src/Summoner/ProjectData.hs
@@ -1,42 +0,0 @@-module Summoner.ProjectData- ( ProjectData (..)- , CustomPrelude (..)- ) where--import Summoner.GhcVer (GhcVer)-import Summoner.License (License, LicenseName)---data CustomPrelude = Prelude- { cpPackage :: Text- , cpModule :: Text- } deriving (Show, Eq)---- | Data needed for project creation.-data ProjectData = ProjectData- { repo :: Text -- ^ repository name- , owner :: Text -- ^ github username- , description :: Text -- ^ project description- , nm :: Text -- ^ full name- , email :: Text -- ^ e-mail- , year :: Text -- ^ year- , category :: Text -- ^ project category- , licenseName :: LicenseName -- ^ type of license- , licenseText :: License -- ^ license text- , github :: Bool -- ^ github repository- , travis :: Bool -- ^ Travis CI integration- , appVey :: Bool -- ^ AppVeyor CI integration- , isLib :: Bool -- ^ is library- , isExe :: Bool -- ^ is executable- , test :: Bool -- ^ add tests- , bench :: Bool -- ^ add benchmarks- , testedVersions :: [GhcVer] -- ^ ghc versions- , base :: Text -- ^ Base library to use- , prelude :: Maybe CustomPrelude -- ^ custom prelude to be used- , extensions :: [Text] -- ^ default extensions- , warnings :: [Text] -- ^ default warnings- , cabal :: Bool- , stack :: Bool- , stylish :: Maybe Text -- ^ @.stylish-haskell.yaml@ file- , contributing :: Maybe Text -- ^ @CONTRIBUTING.md@ file- } deriving (Show)
src/Summoner/Question.hs view
@@ -5,17 +5,25 @@ -- | This module contains function to proper questioning in terminal. module Summoner.Question- ( printQuestion- , choose+ ( -- * Choose functions.+ choose , chooseYesNo , chooseYesNoBool++ -- * YesNoPrompt+ , YesNoPrompt(..)+ , mkDefaultYesNoPrompt++ -- * Queries , query+ , queryNotNull , queryDef , queryManyRepeatOnFail , checkUniqueName + -- * Customize target message , targetMessageWithText-+ , targetMessage , trueMessage , falseMessage ) where@@ -30,12 +38,49 @@ import qualified Data.Text as T import qualified Relude.Unsafe as Unsafe -------------------------------------------------------------------------------- Yes/No----------------------------------------------------------------------------- +{- | Build a prompt++For example,++@+YesNoPrompt+ { yesNoTarget = "Cabal"+ , yesNoPrompt = "Do you want to add a cabal integration?"}+@++will generate a following prompt message to the user++@+Do you want to add a cabal integration? [y]/n+ -> y+[Cabal] will be added to the project+@++-}+data YesNoPrompt = YesNoPrompt+ { yesNoTarget :: Text -- ^ target (e.g., __TARGET will be added to the project__)+ , yesNoPrompt :: Text -- ^ prompt (e.g., __PROMPT [y]/n__)+ }++{- | Build a prompt with the TARGET name only++It will generate a simple default prompt such that++@+Add TARGET? [y]/n+@++-}+mkDefaultYesNoPrompt+ :: Text -- ^ target name+ -> YesNoPrompt+mkDefaultYesNoPrompt target = YesNoPrompt target ("Add " <> target <> "?")++-- | Represents a user's answer data Answer = Y | N +-- | Parse an answer to 'Answer' yesOrNo :: Text -> Maybe Answer yesOrNo (T.toLower -> answer ) | T.null answer = Just Y@@ -47,15 +92,32 @@ -- IO Questioning ---------------------------------------------------------------------------- -printQuestion :: Text -> [Text] -> IO ()+{- | Prints the given question in the following way:++>>> printQuestion "Which option?" [A, B, C]+"Which option? [A]/B/C"++__ Note__ that the first element in the given list is considered as+the default one.+-}+printQuestion+ :: Text -- ^ Question text.+ -> [Text] -- ^ List of available answers.+ -> IO ()+printQuestion question [] = putTextLn question printQuestion question (def:rest) = do let restSlash = T.intercalate "/" rest putStrFlush question boldDefault def putTextLn $ "/" <> restSlash-printQuestion question [] = putTextLn question -choose :: Show a => (Text -> Maybe a) -> Text -> [a] -> IO a+-- | Allows users to choose one of the given options.+-- It asks the question until the appropriate answer is received.+choose :: Show a+ => (Text -> Maybe a) -- ^ Parse function+ -> Text -- ^ Question text.+ -> [a] -- ^ List of available options.+ -> IO a -- ^ The chosen option. choose parser question choices = do let showChoices = map show choices printQuestion question showChoices@@ -65,26 +127,31 @@ else whenNothing (parser answer) (errorMessage "This wasn't a valid choice." >> choose parser question choices) -chooseYesNo :: Text -- ^ target+-- | Like 'choose' but the possible answer are 'Y' or 'N'.+chooseYesNo :: YesNoPrompt -- ^ Target and Prompt -> IO a -- ^ action for 'Y' answer -> IO a -- ^ action for 'N' answer -> IO a-chooseYesNo target yesDo noDo = do- printQuestion ("Add " <> target <> "?") ["y", "n"]+chooseYesNo p@YesNoPrompt {..} yesDo noDo = do+ printQuestion yesNoPrompt ["y", "n"] answer <- yesOrNo <$> prompt case answer of Nothing -> do errorMessage "This wasn't a valid choice."- chooseYesNo target yesDo noDo- Just Y -> trueMessage target >> yesDo- Just N -> falseMessage target >> noDo+ chooseYesNo p yesDo noDo+ Just Y -> trueMessage yesNoTarget >> yesDo+ Just N -> falseMessage yesNoTarget >> noDo -chooseYesNoBool :: Text -> IO Bool-chooseYesNoBool target = chooseYesNo target (pure True) (pure False)+-- | Like 'chooseYesNo' but returns 'Bool'.+chooseYesNoBool :: YesNoPrompt -> IO Bool+chooseYesNoBool ynPrompt = chooseYesNo ynPrompt (pure True) (pure False) -targetMessage :: Bool -> Text -> IO Bool-targetMessage result target = targetMessageWithText result target "added to the project"+{- | The message after yes/no questions. The output depends on the answer. +@+ __Benchmarks__ will be added to the project+@+-} targetMessageWithText :: Bool -> Text -> Text -> IO Bool targetMessageWithText result target text = do let (color, actionResult) = if result@@ -97,19 +164,37 @@ pure result +-- | Like 'targetMessageWithText' but the text is "added to the project"+targetMessage :: Bool -> Text -> IO Bool+targetMessage result target = targetMessageWithText result target "added to the project"+ trueMessage, falseMessage :: Text -> IO Bool trueMessage = targetMessage True falseMessage = targetMessage False ++{- | Queries for any answer.++@+ Short project description:+ ->+@+-} query :: Text -> IO Text-query question = do+query question = putTextLn question >> prompt+++-- | Queries for an non-empty answer.+queryNotNull :: Text -> IO Text+queryNotNull question = do putTextLn question answer <- prompt if | T.null answer -> do errorMessage "An answer is required."- query question+ queryNotNull question | otherwise -> pure answer +-- | Like 'query' but has the default answer if no answer is specified. queryDef :: Text -> Text -> IO Text queryDef question defAnswer = do putStrFlush question@@ -119,9 +204,12 @@ if | T.null answer -> pure defAnswer | otherwise -> pure answer +-- | Queries many answers. If answers are not parsable shows the failing part+-- and queries again queryManyRepeatOnFail :: forall a . (Text -> Maybe a) -> IO [a] queryManyRepeatOnFail parser = promptLoop where+ -- TODO: probably a good idea to use 'Validation' here to simplify code promptLoop :: IO [a] promptLoop = do answer <- prompt@@ -152,7 +240,7 @@ exist <- doesPathExist $ curPath </> toString nm if exist then do warningMessage "Project with this name is already exist. Please choose another one"- newNm <- query "Project name: "+ newNm <- queryNotNull "Project name: " checkUniqueName newNm else pure nm
+ src/Summoner/Settings.hs view
@@ -0,0 +1,54 @@+module Summoner.Settings+ ( Settings (..)+ , CustomPrelude (..)+ , customPreludeT+ ) where++import Toml (TomlCodec, (.=))++import Summoner.GhcVer (GhcVer)+import Summoner.License (License, LicenseName)++import qualified Toml+++data CustomPrelude = CustomPrelude+ { cpPackage :: Text+ , cpModule :: Text+ } deriving (Show, Eq)++customPreludeT :: TomlCodec CustomPrelude+customPreludeT = CustomPrelude+ <$> Toml.text "package" .= cpPackage+ <*> Toml.text "module" .= cpModule++-- | Data needed for project creation.+data Settings = Settings+ { settingsRepo :: !Text -- ^ repository name+ , settingsOwner :: !Text -- ^ github username+ , settingsDescription :: !Text -- ^ project description+ , settingsFullName :: !Text -- ^ full name+ , settingsEmail :: !Text -- ^ e-mail+ , settingsYear :: !Text -- ^ year+ , settingsCategories :: !Text -- ^ project category+ , settingsLicenseName :: !LicenseName -- ^ type of license+ , settingsLicenseText :: !License -- ^ license text+ , settingsGitHub :: !Bool -- ^ GitHub repository+ , settingsPrivate :: !Bool -- ^ private repository+ , settingsTravis :: !Bool -- ^ Travis CI integration+ , settingsAppVeyor :: !Bool -- ^ AppVeyor CI integration+ , settingsIsLib :: !Bool -- ^ is library+ , settingsIsExe :: !Bool -- ^ is executable+ , settingsTest :: !Bool -- ^ add tests+ , settingsBench :: !Bool -- ^ add benchmarks+ , settingsTestedVersions :: ![GhcVer] -- ^ GHC versions+ , settingsBaseType :: !Text -- ^ Base library to use+ , settingsPrelude :: !(Maybe CustomPrelude) -- ^ custom prelude to be used+ , settingsExtensions :: ![Text] -- ^ default extensions+ , settingsWarnings :: ![Text] -- ^ default warnings+ , settingsCabal :: !Bool+ , settingsStack :: !Bool+ , settingsStylish :: !(Maybe Text) -- ^ @.stylish-haskell.yaml@ file+ , settingsContributing :: !(Maybe Text) -- ^ @CONTRIBUTING.md@ file+ , settingsNoUpload :: !Bool -- ^ do not upload to GitHub+ } deriving (Show)
src/Summoner/Source.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE QuasiQuotes #-}+ module Summoner.Source ( Source (..) , sourceT@@ -6,10 +8,11 @@ import Control.Arrow ((>>>)) import Control.Exception (catch)+import NeatInterpolation (text) import System.Process (readProcess)-import Toml (BiMap, BiToml, Key)+import Toml (BiMap, Key, TomlCodec) -import Summoner.Ansi (errorMessage)+import Summoner.Ansi (errorMessage, infoMessage) import qualified Toml @@ -18,26 +21,43 @@ = Url Text -- | File path to the local source file. | File FilePath+ -- | Link to external file.+ | Link Text deriving (Show, Eq) -sourceT :: Key -> BiToml Source-sourceT nm = Toml.match (Toml._Text >>> _Url) (nm <> "url")- <|> Toml.match (Toml._String >>> _File) (nm <> "file")+matchUrl :: Source -> Maybe Text+matchUrl (Url url) = Just url+matchUrl _ = Nothing++matchFile :: Source -> Maybe FilePath+matchFile (File file) = Just file+matchFile _ = Nothing++matchLink :: Source -> Maybe Text+matchLink (Link link) = Just link+matchLink _ = Nothing++sourceT :: Key -> TomlCodec Source+sourceT nm = Toml.match (_Url >>> Toml._Text) (nm <> "url")+ <|> Toml.match (_File >>> Toml._String) (nm <> "file")+ <|> Toml.match (_Link >>> Toml._Text) (nm <> "link") where- _Url :: BiMap Text Source- _Url = Toml.invert $ Toml.prism (source Just (const Nothing)) Url+ _Url :: BiMap Source Text+ _Url = Toml.prism Url matchUrl - _File :: BiMap FilePath Source- _File = Toml.invert $ Toml.prism (source (const Nothing) Just) File+ _File :: BiMap Source FilePath+ _File = Toml.prism File matchFile - source :: (Text -> c) -> (FilePath -> c) -> Source -> c- source f _ (Url x) = f x- source _ f (File x) = f x+ _Link :: BiMap Source Text+ _Link = Toml.prism Link matchLink -fetchSource :: Source -> IO (Maybe Text)-fetchSource = \case+fetchSource :: Bool -> Source -> IO (Maybe Text)+fetchSource isOffline = \case File path -> catch (Just <$> readFileText path) (fileError path)- Url url -> catch (fetchUrl url) (urlError url)+ Url url -> if isOffline+ then Nothing <$ infoMessage ("Ignoring fetching from URL in offline mode from source: " <> url)+ else fetchUrl url `catch` urlError url+ Link link -> putLink link where fileError :: FilePath -> SomeException -> IO (Maybe Text) fileError path _ = errorMessage ("Couldn't read file: " <> toText path)@@ -49,3 +69,6 @@ fetchUrl :: Text -> IO (Maybe Text) fetchUrl url = Just . toText <$> readProcess "curl" [toString url] ""++ putLink :: Text -> IO (Maybe Text)+ putLink link = pure $ Just [text|See full content of the file [here]($link)|]
src/Summoner/Template.hs view
@@ -1,644 +1,31 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ViewPatterns #-}- -- | This module contains functions for stack template creation. module Summoner.Template ( createProjectTemplate ) where -import Data.List (delete)-import NeatInterpolation (text)--import Summoner.Default (defaultGHC, endLine)-import Summoner.GhcVer (GhcVer (..), baseVer, latestLts, showGhcVer)-import Summoner.License (License (..))-import Summoner.ProjectData (CustomPrelude (..), ProjectData (..))-import Summoner.Text (intercalateMap, packageToModule)+import Summoner.Settings (Settings (..))+import Summoner.Template.Cabal (cabalFile)+import Summoner.Template.Doc (docFiles)+import Summoner.Template.GitHub (gitHubFiles)+import Summoner.Template.Haskell (haskellFiles)+import Summoner.Template.Stack (stackFiles) import Summoner.Tree (TreeFs (..)) -import qualified Data.Text as T -------------------------------------------------------------------------------- Project Directory Creation-------------------------------------------------------------------------------memptyIfFalse :: Monoid m => Bool -> m -> m-memptyIfFalse p val = if p then val else mempty- -- | Creating tree structure of the project.-createProjectTemplate :: ProjectData -> TreeFs-createProjectTemplate ProjectData{..} = Dir (toString repo) $- [ File (toString repo <> ".cabal")- ( createCabalTop- <> memptyIfFalse github createCabalGit- <> memptyIfFalse isLib createCabalLib- <> memptyIfFalse isExe- ( createCabalExe- $ memptyIfFalse isLib $ ", " <> repo )- <> memptyIfFalse test- ( createCabalTest- $ memptyIfFalse isLib $ ", " <> repo )- <> memptyIfFalse bench- ( createCabalBenchmark- $ memptyIfFalse isLib $ ", " <> repo )- )- , File "README.md" readme- , File "CHANGELOG.md" changelog- , File "LICENSE" $ unLicense licenseText+createProjectTemplate :: Settings -> TreeFs+createProjectTemplate settings@Settings{..} = Dir (toString settingsRepo) $ concat+ [ cabal+ , stack+ , haskell+ , docs+ , gitHub ]- ++ createCabalFiles- ++ memptyIfFalse stack (createStackYamls testedVersions)- ++ [File ".gitignore" gitignore | github]- ++ [File ".travis.yml" travisYml | travis]- ++ [File "appveyor.yml" appVeyorYml | appVey]- ++ maybe [] (\x -> [File ".stylish-haskell.yaml" x]) stylish- ++ maybe [] (\x -> [File "CONTRIBUTING.md" x]) contributing where- license = show licenseName-- -- Creates module name from the name of the project- libModuleName :: Text- libModuleName = packageToModule repo-- preludeMod :: Text- preludeMod = case prelude of- Nothing -> ""- Just _ -> "Prelude"-- customPreludePack :: Text- customPreludePack = case prelude of- Nothing -> ""- Just Prelude{..} -> ", " <> cpPackage-- -- all basic project information for `*.cabal` file- createCabalTop :: Text- createCabalTop =- [text|- cabal-version: 1.24- name: $repo- version: 0.0.0- description: $description- synopsis: $description- $githubHomepage- $githubBugReports- license: $license- license-file: LICENSE- author: $nm- maintainer: $email- copyright: $year $nm- category: $category- build-type: Simple- extra-doc-files: README.md- , CHANGELOG.md- tested-with: $testedGhcs- $endLine- |]- where- githubHomepage :: Text = memptyIfFalse github $ "homepage: https://github.com/" <> owner <> "/" <> repo- githubBugReports :: Text = memptyIfFalse github $ "bug-reports: https://github.com/" <> owner <> "/" <> repo <> "/issues"--- testedGhcs :: Text- testedGhcs = intercalateMap ", " (mappend "GHC == " . showGhcVer) testedVersions-- defaultExtensions :: Text- defaultExtensions = case extensions of- [] -> ""- xs -> "default-extensions: " <> T.intercalate "\n " xs-- createCabalGit :: Text- createCabalGit =- [text|- source-repository head- type: git- location: https://github.com/${owner}/${repo}.git- $endLine- |]-- ghcOptions :: Text- ghcOptions = case warnings of- [] -> defaultWarnings- xs -> T.intercalate "\n" xs-- defaultWarnings :: Text- defaultWarnings =- [text|- -Wincomplete-uni-patterns- -Wincomplete-record-updates- -Wcompat- -Widentities- $versionWarnings- |]-- versionWarnings :: Text- versionWarnings- = memptyIfFalse (testedVersions `hasLeast` Ghc801)- "-Wredundant-constraints\n"- <> memptyIfFalse (testedVersions `hasLeast` Ghc822)- "-fhide-source-paths\n"- <> memptyIfFalse (testedVersions `hasLeast` Ghc843)- [text|- -Wmissing-export-lists- -Wpartial-fields- |]- where- hasLeast list el = all (>= el) list-- createCabalLib :: Text- createCabalLib =- [text|- library- hs-source-dirs: src- exposed-modules: $libModuleName- $preludeMod- ghc-options: -Wall- $ghcOptions- build-depends: $base- $customPreludePack- default-language: Haskell2010- $defaultExtensions- $endLine- |]-- createCabalExe :: Text -> Text- createCabalExe r =- [text|- executable $repo- hs-source-dirs: app- main-is: Main.hs- ghc-options: -Wall- -threaded- -rtsopts- -with-rtsopts=-N- $ghcOptions- build-depends: $base- $r- $customPreludePack- default-language: Haskell2010- $defaultExtensions- $endLine- |]-- createCabalTest :: Text -> Text- createCabalTest r =- [text|- test-suite ${repo}-test- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Spec.hs- ghc-options: -Wall- -threaded- -rtsopts- -with-rtsopts=-N- $ghcOptions- build-depends: $base- $r- $customPreludePack- default-language: Haskell2010- $defaultExtensions- $endLine- |]-- createCabalBenchmark :: Text -> Text- createCabalBenchmark r =- [text|- benchmark ${repo}-benchmark- type: exitcode-stdio-1.0- hs-source-dirs: benchmark- main-is: Main.hs- ghc-options: -Wall- -threaded- -rtsopts- -with-rtsopts=-N- $ghcOptions- build-depends: $base- , gauge- $r- $customPreludePack- default-language: Haskell2010- $defaultExtensions- $endLine- |]-- createCabalFiles :: [TreeFs]- createCabalFiles =- [ Dir "app" [exeFile] | isExe ]- ++ [ Dir "test" [testFile] | test ]- ++ [ Dir "benchmark" [benchmarkFile] | bench ]- ++ [ Dir "src" $ libFile : preludeFile | isLib ]-- testFile :: TreeFs- testFile = File "Spec.hs"- [text|- main :: IO ()- main = putStrLn ("Test suite not yet implemented" :: String)- $endLine- |]-- libFile :: TreeFs- libFile = File (toString libModuleName <> ".hs")- [text|- module $libModuleName- ( someFunc- ) where-- someFunc :: IO ()- someFunc = putStrLn ("someFunc" :: String)- $endLine- |]-- preludeFile :: [TreeFs]- preludeFile = case prelude of- Nothing -> []- Just Prelude{..} -> one $ File "Prelude.hs"- [text|- -- | Uses [$cpPackage](https://hackage.haskell.org/package/${cpPackage}) as default Prelude.-- module Prelude- ( module $cpModule- ) where-- import $cpModule- $endLine- |]-- exeFile :: TreeFs- exeFile = File "Main.hs" $ if isLib then createExe else createOnlyExe-- createOnlyExe :: Text- createOnlyExe =- [text|- main :: IO ()- main = putStrLn ("Hello, world!" :: String)- $endLine- |]-- createExe :: Text- createExe =- [text|- import $libModuleName (someFunc)-- main :: IO ()- main = someFunc- $endLine- |]-- benchmarkFile :: TreeFs- benchmarkFile = File "Main.hs"- [text|- import Gauge.Main-- main :: IO ()- main = defaultMain [bench "const" (whnf const ())]- $endLine- |]-- -- create README template- readme :: Text- readme = T.intercalate "\n" $- [ "# " <> repo- , ""- , hackage- , licenseBadge- ]- ++ [stackLtsBadge | stack]- ++ [stackNightlyBadge | stack]- ++ [travisBadge | travis]- ++ [appVeyorBadge | appVey]- ++ [""- , description- ]- where- hackageShield :: Text =- "https://img.shields.io/hackage/v/" <> repo <> ".svg"- hackageLink :: Text =- "https://hackage.haskell.org/package/" <> repo- hackage :: Text = makeBadge "Hackage" hackageShield hackageLink-- licenseShield :: Text =- "https://img.shields.io/badge/license-" <> T.replace "-" "--" license <> "-blue.svg"- licenseBadge :: Text =- makeBadge (license <> " license") licenseShield "LICENSE"-- stackShieldLts :: Text =- "http://stackage.org/package/" <> repo <> "/badge/lts"- stackLinkLts :: Text =- "http://stackage.org/lts/package/" <> repo-- stackShieldNightly :: Text =- "http://stackage.org/package/" <> repo <> "/badge/nightly"- stackLinkNightly :: Text =- "http://stackage.org/nightly/package/" <> repo- stackLtsBadge :: Text =- makeBadge "Stackage Lts" stackShieldLts stackLinkLts- stackNightlyBadge :: Text =- makeBadge "Stackage Nightly" stackShieldNightly stackLinkNightly-- travisShield :: Text =- "https://secure.travis-ci.org/" <> owner <> "/" <> repo <> ".svg"- travisLink :: Text =- "https://travis-ci.org/" <> owner <> "/" <> repo- travisBadge :: Text =- makeBadge "Build status" travisShield travisLink-- appVeyorShield :: Text =- "https://ci.appveyor.com/api/projects/status/github/" <> owner <> "/" <> repo <> "?branch=master&svg=true"- appVeyorLink :: Text =- "https://ci.appveyor.com/project/" <> owner <> "/" <> repo- appVeyorBadge :: Text =- makeBadge "Windows build status" appVeyorShield appVeyorLink-- makeBadge :: Text -> Text -> Text -> Text- makeBadge title shield link = "[![" <> title <> "](" <> shield <> ")](" <> link <> ")"-- -- create .gitignore template- gitignore :: Text- gitignore =- [text|- ### Haskell- dist- dist-*- cabal-dev- *.o- *.hi- *.chi- *.chs.h- *.dyn_o- *.dyn_hi- *.prof- *.aux- *.hp- *.eventlog- .virtualenv- .hsenv- .hpc- .cabal-sandbox/- cabal.sandbox.config- cabal.config- cabal.project.local- .ghc.environment.*- .HTF/- # Stack- .stack-work/-- ### IDE/support- # Vim- [._]*.s[a-v][a-z]- [._]*.sw[a-p]- [._]s[a-v][a-z]- [._]sw[a-p]- *~- tags-- # IntellijIDEA- .idea/- .ideaHaskellLib/- *.iml-- # Atom- .haskell-ghc-mod.json-- # VS- .vscode/-- # Emacs- *#- .dir-locals.el- TAGS-- # other- .DS_Store- $endLine- |]-- -- create CHANGELOG template- changelog :: Text- changelog =- [text|- # Change log-- `$repo` uses [PVP Versioning][1].- $githubLine-- 0.0.0- =====-- * Initially created.-- [1]: https://pvp.haskell.org- $githubFootNote- |]- where- githubLine :: Text = memptyIfFalse github "The change log is available [on GitHub][2]."- githubFootNote :: Text = memptyIfFalse github $- "[2]: https://github.com/" <> owner <> "/" <> repo <> "/releases"-- -- create travis.yml template- travisYml :: Text- travisYml =- let travisStackMtr = memptyIfFalse stack $- T.concat (map travisStackMatrixItem $ delete defaultGHC testedVersions)- <> travisStackMatrixDefaultItem- travisCabalMtr = memptyIfFalse cabal $- T.concat $ map travisCabalMatrixItem testedVersions- installAndScript =- if cabal- then if stack- then installScriptBoth- else installScriptCabal- else installScriptStack- travisCabalCache = memptyIfFalse cabal "- \"$HOME/.cabal\""- travisStackCache = memptyIfFalse stack- [text|- - "$$HOME/.stack"- - "$$TRAVIS_BUILD_DIR/.stack-work"- |]- in- [text|- sudo: true- language: haskell-- git:- depth: 5-- cache:- directories:- $travisCabalCache- $travisStackCache-- matrix:- include:-- $travisCabalMtr- $travisStackMtr-- $installAndScript-- notifications:- email: false- $endLine- |]-- cabalTest :: Text- cabalTest = if test then "cabal new-test" else "echo 'No tests'"-- travisCabalMatrixItem :: GhcVer -> Text- travisCabalMatrixItem (showGhcVer -> ghcV) =- [text|- - ghc: ${ghcV}- env: GHCVER='${ghcV}' CABALVER='head'- os: linux- addons:- apt:- sources:- - hvr-ghc- packages:- - ghc-${ghcV}- - cabal-install-head- $endLine- |]-- travisStackMatrixItem :: GhcVer -> Text- travisStackMatrixItem (showGhcVer -> ghcV) =- [text|- - ghc: ${ghcV}- env: GHCVER='${ghcV}' STACK_YAML="$$TRAVIS_BUILD_DIR/stack-$$GHCVER.yaml"- os: linux- addons:- apt:- packages:- - libgmp-dev- $endLine- |]-- travisStackMatrixDefaultItem :: Text- travisStackMatrixDefaultItem = let defGhc = showGhcVer defaultGHC in- [text|- - ghc: ${defGhc}- env: GHCVER='${defGhc}' STACK_YAML="$$TRAVIS_BUILD_DIR/stack.yaml"- os: linux- addons:- apt:- packages:- - libgmp-dev- $endLine- |]-- installScriptBoth :: Text- installScriptBoth =- [text|- install:- - |- if [ -z "$$STACK_YAML" ]; then- export PATH="/opt/ghc/$$GHCVER/bin:/opt/cabal/$$CABALVER/bin:$$PATH"- echo $$PATH- cabal new-update- cabal new-build --enable-tests --enable-benchmarks- else- mkdir -p ~/.local/bin- export PATH="$$HOME/.local/bin:$$PATH"- travis_retry curl -L 'https://www.stackage.org/stack/linux-x86_64' | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'- stack --version- stack setup --no-terminal --install-cabal 2.0.1.0- stack ghc -- --version- stack build --only-dependencies --no-terminal- fi- script:- - |- if [ -z "$$STACK_YAML" ]; then- ${cabalTest}- else- stack build --test --bench --no-run-benchmarks --no-terminal- fi- $endLine- |]-- installScriptCabal :: Text- installScriptCabal =- [text|- install:- - export PATH="/opt/ghc/$$GHCVER/bin:/opt/cabal/$$CABALVER/bin:$$PATH"- - echo $$PATH- - cabal new-update- - cabal new-build --enable-tests --enable-benchmarks- script:- - ${cabalTest}- $endLine- |]-- installScriptStack :: Text- installScriptStack =- [text|- install:- - mkdir -p ~/.local/bin- - export PATH="$$HOME/.local/bin:$$PATH"- - travis_retry curl -L 'https://www.stackage.org/stack/linux-x86_64' | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'- - stack --version- - stack setup --no-terminal --install-cabal 2.0.1.0- - stack ghc -- --version- - stack build --only-dependencies --no-terminal- script:- - stack build --test --bench --no-run-benchmarks --no-terminal- $endLine- |]-- -- create @stack.yaml@ file with LTS corresponding to specified ghc version- createStackYamls :: [GhcVer] -> [TreeFs]- createStackYamls = map createStackYaml- where- createStackYaml :: GhcVer -> TreeFs- createStackYaml ghcV = let ver = case ghcV of- Ghc843 -> ""- _ -> "-" <> showGhcVer ghcV- in stackYaml ver (latestLts ghcV) (baseVer ghcV)- where- stackYaml :: Text -> Text -> Text -> TreeFs- stackYaml ghc lts baseV = File (toString $ "stack" <> ghc <> ".yaml")- [text|- resolver: lts-${lts}-- $extraDeps-- $ghcOpts- $endLine- |]- where- extraDeps :: Text- extraDeps = case prelude of- Nothing -> ""- Just _ -> "extra-deps: [base-noprelude-" <> baseV <> "]"- ghcOpts :: Text- ghcOpts = if ghcV <= Ghc802 then- ""- else- [text|- ghc-options:- "$$locals": -fhide-source-paths- |]--- -- create appveyor.yml template- appVeyorYml :: Text- appVeyorYml =- [text|- build: off-- before_test:- # http://help.appveyor.com/discussions/problems/6312-curl-command-not-found- - set PATH=C:\Program Files\Git\mingw64\bin;%PATH%-- - curl -sS -ostack.zip -L --insecure http://www.stackage.org/stack/windows-i386- - 7z x stack.zip stack.exe-- clone_folder: "c:\\stack"- environment:- global:- STACK_ROOT: "c:\\sr"-- test_script:- - stack setup > nul- # The ugly echo "" hack is to avoid complaints about 0 being an invalid file- # descriptor- - echo "" | stack --no-terminal build --bench --no-run-benchmarks --test- |]+ cabal, stack :: [TreeFs]+ cabal = [cabalFile settings]+ stack = memptyIfFalse settingsStack $ stackFiles settings -- TODO: write more elegant+ haskell = haskellFiles settings+ docs = docFiles settings+ gitHub = gitHubFiles settings
+ src/Summoner/Template/Cabal.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE QuasiQuotes #-}++module Summoner.Template.Cabal+ ( cabalFile+ ) where++import NeatInterpolation (text)++import Summoner.GhcVer (GhcVer (..), cabalBaseVersions, showGhcVer)+import Summoner.License (LicenseName (..), cabalLicense)+import Summoner.Settings (CustomPrelude (..), Settings (..))+import Summoner.Text (intercalateMap, packageToModule)+import Summoner.Tree (TreeFs (..))++import qualified Data.Text as T+++cabalFile :: Settings -> TreeFs+cabalFile Settings{..} = File (toString settingsRepo ++ ".cabal") cabalFileContent+ where+ cabalFileContent :: Text+ cabalFileContent = T.concat+ [ cabalHeader+ , memptyIfFalse settingsGitHub sourceRepository+ , memptyIfFalse settingsIsLib libraryStanza+ , memptyIfFalse settingsIsExe $ executableStanza $ memptyIfFalse settingsIsLib $ ", " <> settingsRepo+ , memptyIfFalse settingsTest $ testSuiteStanza $ memptyIfFalse settingsIsLib $ ", " <> settingsRepo+ , memptyIfFalse settingsBench $ benchmarkStanza $ memptyIfFalse settingsIsLib $ ", " <> settingsRepo+ ]++ -- TODO: do something to not have empty lines+ cabalHeader :: Text+ cabalHeader = unlines $+ [ "cabal-version: 2.0"+ , "name: " <> settingsRepo+ , "version: 0.0.0"+ , "synopsis: " <> settingsDescription+ , "description: " <> settingsDescription ] +++ [ "homepage: " <> githubUrl | settingsGitHub ] +++ [ "bug-reports: " <> githubBugReports | settingsGitHub ] +++ ( "license: " <> licenseName) :+ [ "license-file: LICENSE" | settingsLicenseName /= None] +++ [ "author: " <> settingsFullName+ , "maintainer: " <> settingsEmail+ , "copyright: " <> settingsYear <> " " <> settingsFullName ] +++ [ "category: " <> settingsCategories | "" /= settingsCategories ] +++ [ "build-type: Simple"+ , "extra-doc-files: README.md"+ , " , CHANGELOG.md"+ , "tested-with: " <> testedGhcs+ ]++ githubUrl, githubBugReports :: Text+ githubUrl = "https://github.com/" <> settingsOwner <> "/" <> settingsRepo+ githubBugReports = githubUrl <> "/issues"++ licenseName, libModuleName :: Text+ licenseName = cabalLicense settingsLicenseName+ libModuleName = packageToModule settingsRepo++ testedGhcs :: Text+ testedGhcs = intercalateMap ", " (mappend "GHC == " . showGhcVer) settingsTestedVersions++ sourceRepository :: Text+ sourceRepository =+ [text|+ $endLine+ source-repository head+ type: git+ location: ${githubUrl}.git+ |]++ baseBounds :: Text+ baseBounds = cabalBaseVersions settingsTestedVersions++ libraryStanza :: Text+ libraryStanza =+ [text|+ $endLine+ library+ hs-source-dirs: src+ exposed-modules: $libModuleName+ $preludeMod++ build-depends: $settingsBaseType $baseBounds+ $commaPreludeLibrary++ ghc-options: -Wall+ $ghcOptions++ default-language: Haskell2010+ |] <> defaultExtensions++ executableStanza :: Text -> Text+ executableStanza commaRepo =+ [text|+ $endLine+ executable $settingsRepo+ hs-source-dirs: app+ main-is: Main.hs++ build-depends: $settingsBaseType $baseBounds+ $commaRepo+ $commaPreludeLibrary++ ghc-options: -Wall+ -threaded+ -rtsopts+ -with-rtsopts=-N+ $ghcOptions++ default-language: Haskell2010+ |] <> defaultExtensions++ testSuiteStanza :: Text -> Text+ testSuiteStanza commaRepo =+ [text|+ $endLine+ test-suite ${settingsRepo}-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs++ build-depends: $settingsBaseType $baseBounds+ $commaRepo+ $commaPreludeLibrary++ ghc-options: -Wall+ -threaded+ -rtsopts+ -with-rtsopts=-N+ $ghcOptions++ default-language: Haskell2010+ |] <> defaultExtensions++ benchmarkStanza :: Text -> Text+ benchmarkStanza commaRepo =+ [text|+ $endLine+ benchmark ${settingsRepo}-benchmark+ type: exitcode-stdio-1.0+ hs-source-dirs: benchmark+ main-is: Main.hs++ build-depends: $settingsBaseType $baseBounds+ , gauge+ $commaRepo+ $commaPreludeLibrary++ ghc-options: -Wall+ -threaded+ -rtsopts+ -with-rtsopts=-N+ $ghcOptions++ default-language: Haskell2010+ |] <> defaultExtensions+++ preludeMod, commaPreludeLibrary :: Text+ (preludeMod, commaPreludeLibrary) = case settingsPrelude of+ Nothing -> ("", "")+ Just CustomPrelude{..} -> ("Prelude", ", " <> cpPackage)++ defaultExtensions :: Text+ defaultExtensions = case settingsExtensions of+ [] -> ""+ xs -> " default-extensions: "+ <> T.intercalate "\n " xs+ <> "\n"++ ghcOptions :: Text+ ghcOptions = case settingsWarnings of+ [] -> defaultWarnings+ xs -> T.intercalate "\n" xs++ defaultWarnings :: Text+ defaultWarnings =+ [text|+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wcompat+ -Widentities+ $versionWarnings+ |]++ versionWarnings :: Text+ versionWarnings+ = memptyIfFalse (settingsTestedVersions `hasLeast` Ghc801)+ "-Wredundant-constraints\n"+ <> memptyIfFalse (settingsTestedVersions `hasLeast` Ghc822)+ "-fhide-source-paths\n"+ <> memptyIfFalse (settingsTestedVersions `hasLeast` Ghc843)+ [text|+ -Wmissing-export-lists+ -Wpartial-fields+ |]+ where+ hasLeast :: [GhcVer] -> GhcVer -> Bool+ hasLeast list el = all (>= el) list
+ src/Summoner/Template/Doc.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE QuasiQuotes #-}++module Summoner.Template.Doc+ ( docFiles+ ) where++import NeatInterpolation (text)++import Summoner.License (License (..), LicenseName (None))+import Summoner.Settings (Settings (..))+import Summoner.Tree (TreeFs (..))++import qualified Data.Text as T+++docFiles :: Settings -> [TreeFs]+docFiles Settings{..} =+ [ File "README.md" readme+ , File "CHANGELOG.md" changelog ] +++ [ File "LICENSE" (unLicense settingsLicenseText) | hasLicense ] +++ maybeToList (File "CONTRIBUTING.md" <$> settingsContributing)+ where+ hasLicense :: Bool+ hasLicense = settingsLicenseName /= None++ licenseName :: Text+ licenseName = show settingsLicenseName++ readme :: Text+ readme = T.intercalate "\n" $+ [ "# " <> settingsRepo+ , ""+ , hackage+ ]+ ++ [licenseBadge | hasLicense]+ ++ [stackLtsBadge | settingsStack]+ ++ [stackNightlyBadge | settingsStack]+ ++ [travisBadge | settingsTravis]+ ++ [appVeyorBadge | settingsAppVeyor]+ ++ [""+ , settingsDescription+ ]+ where+ hackageShield :: Text =+ "https://img.shields.io/hackage/v/" <> settingsRepo <> ".svg"+ hackageLink :: Text =+ "https://hackage.haskell.org/package/" <> settingsRepo+ hackage :: Text = makeBadge "Hackage" hackageShield hackageLink++ licenseShield :: Text =+ "https://img.shields.io/badge/license-" <> T.replace "-" "--" licenseName <> "-blue.svg"+ licenseBadge :: Text =+ makeBadge (licenseName <> " license") licenseShield "LICENSE"++ stackShieldLts :: Text =+ "http://stackage.org/package/" <> settingsRepo <> "/badge/lts"+ stackLinkLts :: Text =+ "http://stackage.org/lts/package/" <> settingsRepo++ stackShieldNightly :: Text =+ "http://stackage.org/package/" <> settingsRepo <> "/badge/nightly"+ stackLinkNightly :: Text =+ "http://stackage.org/nightly/package/" <> settingsRepo+ stackLtsBadge :: Text =+ makeBadge "Stackage Lts" stackShieldLts stackLinkLts+ stackNightlyBadge :: Text =+ makeBadge "Stackage Nightly" stackShieldNightly stackLinkNightly++ travisShield :: Text =+ "https://secure.travis-ci.org/" <> settingsOwner <> "/" <> settingsRepo <> ".svg"+ travisLink :: Text =+ "https://travis-ci.org/" <> settingsOwner <> "/" <> settingsRepo+ travisBadge :: Text =+ makeBadge "Build status" travisShield travisLink++ appVeyorShield :: Text =+ "https://ci.appveyor.com/api/projects/status/github/" <> settingsOwner <> "/" <> settingsRepo <> "?branch=master&svg=true"+ appVeyorLink :: Text =+ "https://ci.appveyor.com/project/" <> settingsOwner <> "/" <> settingsRepo+ appVeyorBadge :: Text =+ makeBadge "Windows build status" appVeyorShield appVeyorLink++ makeBadge :: Text -> Text -> Text -> Text+ makeBadge title shield link = "[![" <> title <> "](" <> shield <> ")](" <> link <> ")"++ changelog :: Text+ changelog = T.stripEnd+ [text|+ # Changelog++ `$settingsRepo` uses [PVP Versioning][1].+ $githubLine++ 0.0.0+ =====++ * Initially created.++ [1]: https://pvp.haskell.org+ $githubFootNote+ |]+ where+ githubLine :: Text = memptyIfFalse settingsGitHub "The changelog is available [on GitHub][2]."+ githubFootNote :: Text = memptyIfFalse settingsGitHub $+ "[2]: https://github.com/" <> settingsOwner <> "/" <> settingsRepo <> "/releases"
+ src/Summoner/Template/GitHub.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ViewPatterns #-}++module Summoner.Template.GitHub+ ( gitHubFiles+ ) where++import Data.List (delete)+import NeatInterpolation (text)++import Summoner.Default (defaultGHC)+import Summoner.GhcVer (GhcVer (..), showGhcVer)+import Summoner.Settings (Settings (..))+import Summoner.Text (tconcatMap)+import Summoner.Tree (TreeFs (..))+++gitHubFiles :: Settings -> [TreeFs]+gitHubFiles Settings{..} =+ [File ".gitignore" gitignore | settingsGitHub]+ ++ [File ".travis.yml" travisYml | settingsTravis]+ ++ [File "appveyor.yml" appVeyorYml | settingsAppVeyor]+ where+ -- create .gitignore template+ gitignore :: Text+ gitignore =+ [text|+ ### Haskell+ dist+ dist-*+ cabal-dev+ *.o+ *.hi+ *.chi+ *.chs.h+ *.dyn_o+ *.dyn_hi+ *.prof+ *.aux+ *.hp+ *.eventlog+ .virtualenv+ .hsenv+ .hpc+ .cabal-sandbox/+ cabal.sandbox.config+ cabal.config+ cabal.project.local+ .ghc.environment.*+ .HTF/+ # Stack+ .stack-work/++ ### IDE/support+ # Vim+ [._]*.s[a-v][a-z]+ [._]*.sw[a-p]+ [._]s[a-v][a-z]+ [._]sw[a-p]+ *~+ tags++ # IntellijIDEA+ .idea/+ .ideaHaskellLib/+ *.iml++ # Atom+ .haskell-ghc-mod.json++ # VS+ .vscode/++ # Emacs+ *#+ .dir-locals.el+ TAGS++ # other+ .DS_Store+ |]+++ -- create travis.yml template+ travisYml :: Text+ travisYml =+ [text|+ sudo: true+ language: haskell++ git:+ depth: 5++ cache:+ directories:+ $travisCabalCache+ $travisStackCache++ matrix:+ include:+ $travisCabalMtr+ $travisStackMtr++ $installAndScript++ notifications:+ email: false+ |]++ travisCabalCache, travisStackCache :: Text+ travisCabalCache = memptyIfFalse settingsCabal "- \"$HOME/.cabal\""+ travisStackCache = memptyIfFalse settingsStack+ [text|+ - "$$HOME/.stack"+ - "$$TRAVIS_BUILD_DIR/.stack-work"+ |]+++ cabalTest :: Text+ cabalTest = if settingsTest then "cabal new-test" else "echo 'No tests'"++ travisCabalMtr :: Text+ travisCabalMtr = memptyIfFalse settingsCabal $+ tconcatMap travisCabalMatrixItem settingsTestedVersions++ travisCabalMatrixItem :: GhcVer -> Text+ travisCabalMatrixItem (showGhcVer -> ghcV) =+ [text|+ $endLine+ - ghc: ${ghcV}+ env: GHCVER='${ghcV}' CABALVER='head'+ os: linux+ addons:+ apt:+ sources:+ - hvr-ghc+ packages:+ - ghc-${ghcV}+ - cabal-install-head+ |]++ travisStackMtr :: Text+ travisStackMtr = memptyIfFalse settingsStack $+ tconcatMap travisStackMatrixItem (delete defaultGHC settingsTestedVersions)+ <> travisStackMatrixDefaultItem++ travisStackMatrixItem :: GhcVer -> Text+ travisStackMatrixItem (showGhcVer -> ghcV) =+ [text|+ $endLine+ - ghc: ${ghcV}+ env: GHCVER='${ghcV}' STACK_YAML="$$TRAVIS_BUILD_DIR/stack-$$GHCVER.yaml"+ os: linux+ addons:+ apt:+ packages:+ - libgmp-dev+ |]++ travisStackMatrixDefaultItem :: Text+ travisStackMatrixDefaultItem = let defGhc = showGhcVer defaultGHC in+ [text|+ $endLine+ - ghc: ${defGhc}+ env: GHCVER='${defGhc}' STACK_YAML="$$TRAVIS_BUILD_DIR/stack.yaml"+ os: linux+ addons:+ apt:+ packages:+ - libgmp-dev+ |]++ installAndScript :: Text+ installAndScript =+ if settingsCabal+ then if settingsStack+ then installScriptBoth+ else installScriptCabal+ else installScriptStack++ installScriptBoth :: Text+ installScriptBoth =+ [text|+ install:+ - |+ if [ -z "$$STACK_YAML" ]; then+ export PATH="/opt/ghc/$$GHCVER/bin:/opt/cabal/$$CABALVER/bin:$$PATH"+ echo $$PATH+ cabal new-update+ cabal new-build --enable-tests --enable-benchmarks+ else+ mkdir -p ~/.local/bin+ export PATH="$$HOME/.local/bin:$$PATH"+ travis_retry curl -L 'https://www.stackage.org/stack/linux-x86_64' | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'+ stack --version+ stack setup --no-terminal --install-cabal 2.2.0.1+ stack ghc -- --version+ stack build --only-dependencies --no-terminal+ fi++ script:+ - |+ if [ -z "$$STACK_YAML" ]; then+ ${cabalTest}+ else+ stack build --test --bench --no-run-benchmarks --no-terminal --ghc-options=-Werror+ fi++ - curl -sSL https://raw.github.com/ndmitchell/neil/master/misc/travis.sh | sh -s -- hlint .+ |]++ installScriptCabal :: Text+ installScriptCabal =+ [text|+ install:+ - export PATH="/opt/ghc/$$GHCVER/bin:/opt/cabal/$$CABALVER/bin:$$PATH"+ - echo $$PATH+ - cabal new-update+ - cabal new-build --enable-tests --enable-benchmarks++ script:+ - ${cabalTest}+ |]++ installScriptStack :: Text+ installScriptStack =+ [text|+ install:+ - mkdir -p ~/.local/bin+ - export PATH="$$HOME/.local/bin:$$PATH"+ - travis_retry curl -L 'https://www.stackage.org/stack/linux-x86_64' | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'+ - stack --version+ - stack setup --no-terminal --install-cabal 2.2.0.1+ - stack ghc -- --version+ - stack build --only-dependencies --no-terminal++ script:+ - stack build --test --bench --no-run-benchmarks --no-terminal --ghc-options=-Werror+ |]++++ -- create appveyor.yml template+ appVeyorYml :: Text+ appVeyorYml =+ [text|+ build: off++ before_test:+ # http://help.appveyor.com/discussions/problems/6312-curl-command-not-found+ - set PATH=C:\Program Files\Git\mingw64\bin;%PATH%++ - curl -sS -ostack.zip -L --insecure http://www.stackage.org/stack/windows-x86_64+ - 7z x stack.zip stack.exe++ clone_folder: "c:\\stack"+ environment:+ global:+ STACK_ROOT: "c:\\sr"++ test_script:+ - stack setup > nul+ # The ugly echo "" hack is to avoid complaints about 0 being an invalid file+ # descriptor+ - echo "" | stack --arch x86_64 --no-terminal build --bench --no-run-benchmarks --test+ |]
+ src/Summoner/Template/Haskell.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE QuasiQuotes #-}++module Summoner.Template.Haskell+ ( haskellFiles+ ) where++import NeatInterpolation (text)++import Summoner.Settings (CustomPrelude (..), Settings (..))+import Summoner.Text (packageToModule)+import Summoner.Tree (TreeFs (..))+++haskellFiles :: Settings -> [TreeFs]+haskellFiles Settings{..} = concat+ [ [ Dir "src" $ libFile : preludeFile | settingsIsLib ]+ , [ Dir "app" [exeFile] | settingsIsExe ]+ , [ Dir "test" [testFile] | settingsTest ]+ , [ Dir "benchmark" [benchmarkFile] | settingsBench ]+ ] ++ maybeToList (File ".stylish-haskell.yaml" <$> settingsStylish)+ where+ libFile :: TreeFs+ libFile = File (toString libModuleName <> ".hs")+ [text|+ module $libModuleName+ ( someFunc+ ) where++ someFunc :: IO ()+ someFunc = putStrLn ("someFunc" :: String)+ |]++ libModuleName :: Text+ libModuleName = packageToModule settingsRepo++ preludeFile :: [TreeFs]+ preludeFile = maybeToList $+ settingsPrelude <&> \CustomPrelude{..} -> File "Prelude.hs"+ [text|+ -- | Uses [$cpPackage](https://hackage.haskell.org/package/${cpPackage}) as default Prelude.++ module Prelude+ ( module $cpModule+ ) where++ import $cpModule+ |]++ exeFile :: TreeFs+ exeFile = File "Main.hs" $ if settingsIsLib then createExe else createOnlyExe++ createOnlyExe :: Text+ createOnlyExe =+ [text|+ module Main (main) where++ main :: IO ()+ main = putStrLn ("Hello, world!" :: String)+ |]++ createExe :: Text+ createExe =+ [text|+ module Main (main) where++ import $libModuleName (someFunc)+++ main :: IO ()+ main = someFunc+ |]++ testFile :: TreeFs+ testFile = File "Spec.hs"+ [text|+ module Main (main) where++ main :: IO ()+ main = putStrLn ("Test suite not yet implemented" :: String)+ |]++ benchmarkFile :: TreeFs+ benchmarkFile = File "Main.hs"+ [text|+ module Main (main) where++ import Gauge.Main+++ main :: IO ()+ main = defaultMain [bench "const" (whnf const ())]+ |]
+ src/Summoner/Template/Stack.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE QuasiQuotes #-}++module Summoner.Template.Stack+ ( stackFiles+ ) where++import NeatInterpolation (text)++import Summoner.GhcVer (GhcVer (..), baseVer, latestLts, showGhcVer)+import Summoner.Settings (Settings (..))+import Summoner.Tree (TreeFs (..))+++stackFiles :: Settings -> [TreeFs]+stackFiles Settings{..} = map createStackYaml settingsTestedVersions+ where+ -- create @stack.yaml@ file with LTS corresponding to specified ghc version+ createStackYaml :: GhcVer -> TreeFs+ createStackYaml ghcV = File (toString $ "stack" <> ver <> ".yaml")+ $ "resolver: lts-" <> latestLts ghcV <> extraDeps <> ghcOpts+ where+ ver :: Text+ ver = case ghcV of+ Ghc844 -> ""+ _ -> "-" <> showGhcVer ghcV++ extraDeps :: Text+ extraDeps = case settingsPrelude of+ Nothing -> ""+ Just _ -> "\n\nextra-deps: [base-noprelude-" <> baseVer ghcV <> "]"++ ghcOpts :: Text+ ghcOpts = memptyIfFalse (ghcV > Ghc802)+ [text|+ $endLine++ ghc-options:+ "$$locals": -fhide-source-paths+ |]
src/Summoner/Text.hs view
@@ -2,6 +2,7 @@ ( packageToModule , intercalateMap , headToUpper+ , tconcatMap ) where import qualified Data.Char as C@@ -10,7 +11,7 @@ -- | Creates module name from the name of the package -- Ex: @my-lovely-project@ — @MyLovelyProject@ packageToModule :: Text -> Text-packageToModule = T.concat . map headToUpper . T.splitOn "-"+packageToModule = tconcatMap headToUpper . T.splitOn "-" -- | Converts every element of list into 'Text' and then joins every element -- into single 'Text' like 'T.intercalate'.@@ -21,3 +22,7 @@ headToUpper t = case T.uncons t of Nothing -> "" Just (x, xs) -> T.cons (C.toUpper x) xs++-- | Convert every element of a list into text, and squash the results+tconcatMap :: (a -> Text) -> [a] -> Text+tconcatMap f = T.concat . map f
src/Summoner/Tree.hs view
@@ -3,6 +3,7 @@ module Summoner.Tree ( TreeFs (..) , traverseTree+ , showBoldTree , showTree ) where @@ -26,29 +27,37 @@ traverseTree (File name content) = writeFileText name content -- | Pretty shows the directory tree content.-showTree :: TreeFs -> Text-showTree = unlines . showOne " " "" ""+showBoldTree :: TreeFs -> Text+showBoldTree = showTree True -showOne :: Text -> Text -> Text -> TreeFs -> [Text]-showOne leader tie arm (File fp _) = [leader <> arm <> tie <> toText fp]-showOne leader tie arm (Dir fp (sortWith treeFp -> trees)) =- nodeRep : showChildren trees (leader <> extension)+-- | Pretty shows tree with options.+showTree+ :: Bool -- ^ Print directories bold.+ -> TreeFs -- ^ Given tree.+ -> Text -- ^ Pretty output.+showTree isBold = unlines . showOne " " "" "" where- nodeRep :: Text- nodeRep = leader <> arm <> tie <> boldDir (fp <> "/")+ showOne :: Text -> Text -> Text -> TreeFs -> [Text]+ showOne leader tie arm (File fp _) = [leader <> arm <> tie <> toText fp]+ showOne leader tie arm (Dir fp (sortWith treeFp -> trees)) =+ nodeRep : showChildren trees (leader <> extension) where- boldDir str = toText- $ boldCode- <> str- <> resetCode+ nodeRep :: Text+ nodeRep = leader <> arm <> tie <> boldDir (fp <> "/")+ where+ boldDir :: FilePath -> Text+ boldDir str = toText $+ if isBold+ then boldCode <> str <> resetCode+ else str - extension :: Text- extension = case arm of "" -> ""; "└" -> " "; _ -> "│ "+ extension :: Text+ extension = case arm of "" -> ""; "└" -> " "; _ -> "│ " -showChildren :: [TreeFs] -> Text -> [Text]-showChildren children leader =- let arms = replicate (length children - 1) "│" <> ["└"]- in concat (zipWith (showOne leader "── ") arms children)+ showChildren :: [TreeFs] -> Text -> [Text]+ showChildren children leader =+ let arms = replicate (length children - 1) "├" <> ["└"]+ in concat (zipWith (showOne leader "── ") arms children) -- For sorting in alphabetic order. treeFp :: TreeFs -> FilePath
− src/Summoner/Validation.hs
@@ -1,27 +0,0 @@-module Summoner.Validation- ( Validation (..)- ) where---- | 'Validation' is 'Either' with a Left that is a 'Monoid'-data Validation e a- = Failure e- | Success a- deriving (Eq, Ord, Show)--instance Functor (Validation e) where- fmap _ (Failure e) = Failure e- fmap f (Success a) = Success (f a)--instance Semigroup e => Semigroup (Validation e a) where- Failure e1 <> Failure e2 = Failure (e1 <> e2)- Failure _ <> Success a2 = Success a2- Success a1 <> Failure _ = Success a1- Success a1 <> Success _ = Success a1--instance Semigroup e => Applicative (Validation e) where- pure = Success-- Failure e1 <*> Failure e2 = Failure (e1 <> e2)- Failure e1 <*> Success _ = Failure e1- Success _ <*> Failure e2 = Failure e2- Success f <*> Success a = Success (f a)
summoner.cabal view
@@ -1,9 +1,9 @@ cabal-version: 2.0 name: summoner-version: 1.1.0.1-synopsis: Tool for creating completely configured production Haskell projects.-description: Tool for creating completely configured production Haskell projects.- See README.md for details.+version: 1.2.0+synopsis: Tool for scaffolding completely configured production Haskell projects.+description: Tool for scaffolding completely configured production Haskell projects.+ See [README.md](https://github.com/kowainik/summoner#-summoner) for details. homepage: https://github.com/kowainik/summoner bug-reports: https://github.com/kowainik/summoner/issues license: MPL-2.0@@ -17,7 +17,8 @@ extra-doc-files: README.md , CHANGELOG.md tested-with: GHC == 8.2.2- , GHC == 8.4.3+ , GHC == 8.4.4+ , GHC == 8.6.2 source-repository head type: git@@ -25,8 +26,7 @@ library hs-source-dirs: src- exposed-modules: Prelude- Summoner+ exposed-modules: Summoner Summoner.Ansi Summoner.CLI Summoner.Config@@ -36,32 +36,37 @@ Summoner.License Summoner.Process Summoner.Project- Summoner.ProjectData Summoner.Question+ Summoner.Settings Summoner.Source Summoner.Template+ Summoner.Template.Cabal+ Summoner.Template.Doc+ Summoner.Template.GitHub+ Summoner.Template.Haskell+ Summoner.Template.Stack Summoner.Text Summoner.Tree- Summoner.Validation - other-modules: Paths_summoner autogen-modules: Paths_summoner+ other-modules: Paths_summoner+ Prelude - build-depends: base-noprelude >= 4.10 && < 5- , aeson- , ansi-terminal- , bytestring- , directory- , filepath- , generic-deriving- , gitrev+ build-depends: base-noprelude >= 4.10 && < 4.13+ , aeson >= 1.2.4.0 && < 1.5+ , ansi-terminal ^>= 0.8.0.4+ , bytestring ^>= 0.10.8.2+ , directory ^>= 1.3.0.2+ , filepath ^>= 1.4.1.2+ , generic-deriving ^>= 1.12.2+ , gitrev ^>= 1.3.1 , neat-interpolation ^>= 0.3.2.2- , optparse-applicative- , process- , text- , time- , tomland ^>= 0.4.0- , relude ^>= 0.3.0+ , optparse-applicative ^>= 0.14.2.0+ , process ^>= 1.6.1.0+ , relude ^>= 0.4.0+ , text ^>= 1.2.3.0+ , time ^>= 1.8+ , tomland ^>= 0.5.0 ghc-options: -Wall -Wincomplete-uni-patterns@@ -84,7 +89,10 @@ executable summon hs-source-dirs: app- main-is: Main.hs+ main-is: Cli.hs+ build-depends: base >= 4.10 && < 4.13+ , summoner+ ghc-options: -Wall -threaded -rtsopts@@ -95,9 +103,7 @@ -Widentities -Wredundant-constraints -fhide-source-paths- build-depends: base-noprelude- , relude- , summoner+ default-language: Haskell2010 test-suite summoner-test@@ -106,17 +112,21 @@ main-is: Spec.hs other-modules: Test.DecisionSpec+ Test.Golden Test.TomlSpec+ Test.QuestionSpec+ Prelude - build-tool-depends: tasty-discover:tasty-discover- build-depends: base-noprelude- , hedgehog+ build-depends: base-noprelude >= 4.10 && < 4.13+ , filepath+ , hedgehog >= 0.5.3 && < 0.7+ , hspec >= 2.4.8+ , neat-interpolation , relude- , tasty- , tasty-hedgehog , tomland , summoner + ghc-options: -Wall -threaded -rtsopts@@ -128,5 +138,7 @@ -Wredundant-constraints -fhide-source-paths - default-extensions: RecordWildCards+ default-extensions: OverloadedStrings+ RecordWildCards+ default-language: Haskell2010
+ test/Prelude.hs view
@@ -0,0 +1,9 @@+-- | Uses @relude@ as a default prelude.++module Prelude+ ( module Relude+ , module Relude.Extra+ ) where++import Relude+import Relude.Extra.Enum as Relude.Extra (inverseMap, universe)
test/Spec.hs view
@@ -1,1 +1,27 @@-{-# OPTIONS_GHC -F -pgmF tasty-discover #-}+module Main where++import Hedgehog (Group (..), checkParallel)+import Test.Hspec (hspec)++import Test.DecisionSpec (decisionMonoidMempty, decisionSemigroupAssoc)+import Test.Golden (goldenSpec)+import Test.QuestionSpec (yesNoPromptSpec)+import Test.TomlSpec (tomlProp)+++main :: IO ()+main = do+ hspec $ do+ yesNoPromptSpec+ goldenSpec+ ifM (checkParallel hedgehogTests) exitSuccess exitFailure++hedgehogTests :: Group+hedgehogTests = Group "Roundtrip properties"+ [ decisionSemigroupAssoc `named` "Decision Semigroup:Assoc"+ , decisionMonoidMempty `named` "Decision Monoid:Mempty"+ , tomlProp `named` "decode . encode == id"+ ]+ where+ named :: a -> b -> (b, a)+ named = flip (,)
test/Test/DecisionSpec.hs view
@@ -1,22 +1,27 @@-module Test.DecisionSpec where+module Test.DecisionSpec+ ( decisionSemigroupAssoc+ , decisionMonoidMempty -import Hedgehog (MonadGen, forAll, property, (===))-import Test.Tasty (TestTree)-import Test.Tasty.Hedgehog (testProperty)+ -- * Gen+ , genDecision+ ) where +import Hedgehog (MonadGen, Property, forAll, property, (===))+ import Summoner.Decision (Decision) import qualified Hedgehog.Gen as Gen -test_decisionSemigroupAssoc :: [TestTree]-test_decisionSemigroupAssoc = pure $ testProperty "Decision Semigroup:Assoc" $ property $ do++decisionSemigroupAssoc :: Property+decisionSemigroupAssoc = property $ do x <- forAll genDecision y <- forAll genDecision z <- forAll genDecision (x <> y) <> z === x <> (y <> z) -test_decisionMonoidMempty :: [TestTree]-test_decisionMonoidMempty = pure $ testProperty "Decision Monoid:Mempty" $ property $ do+decisionMonoidMempty :: Property+decisionMonoidMempty = property $ do x <- forAll genDecision x <> mempty === x mempty <> x === x
+ test/Test/Golden.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE QuasiQuotes #-}++{- | Golden tests for @summoner@.++In the @test/golden@ folder we now have two projects that are created by+@summoner@.++* @fullProject@ – the project that has all options enabled.+* @smallProject@ – the project that has limited options enabled.++The purpose of this tests is to check that with the corresponding 'Settings'+the tool creates the expected project.++-}++module Test.Golden+ ( goldenSpec+ ) where++import NeatInterpolation (text)+import System.FilePath ((</>))+import Test.Hspec (Spec, describe, it, shouldReturn)++import Summoner (CustomPrelude (..), GhcVer (..), License (..), LicenseName (..), Settings (..),+ defaultGHC)+import Summoner.Template (createProjectTemplate)+import Summoner.Tree (TreeFs (..))+++goldenSpec :: Spec+goldenSpec = describe "golden tests" $ do+ it "correctly creates full project" $+ checkProject fullProject+ it "correctly creates small project" $+ checkProject smallProject+ where+ checkProject pr = compareTree "test/golden" (createProjectTemplate pr) `shouldReturn` []+++-- | Returns the list of the files that don't match the golden ones.+compareTree :: FilePath -> TreeFs -> IO [FilePath]+compareTree filePath (Dir name children) =+ foldlM (\l ch -> (l ++) <$> compareTree (filePath </> name) ch) [] children+compareTree filePath (File name content) = do+ let curFile = filePath </> name+ golden <- readFileText curFile+ pure $ if golden == content then [] else [curFile]++fullProject :: Settings+fullProject = Settings+ { settingsRepo = "fullProject"+ , settingsOwner = "kowainik"+ , settingsDescription = "Full test project"+ , settingsFullName = "Kowainik"+ , settingsEmail = "xrom.xkov@gmail.com"+ , settingsYear = "2018"+ , settingsCategories = "Testing"+ , settingsLicenseName = MIT+ , settingsLicenseText = mitLicense+ , settingsGitHub = True+ , settingsPrivate = True+ , settingsTravis = True+ , settingsAppVeyor = True+ , settingsIsLib = True+ , settingsIsExe = True+ , settingsTest = True+ , settingsBench = True+ , settingsTestedVersions = [Ghc802, Ghc822, Ghc844]+ , settingsBaseType = "base-noprelude"+ , settingsPrelude = Just $ CustomPrelude "relude" "Relude"+ , settingsExtensions = ["ConstraintKinds", "LambdaCase", "OverloadedStrings"]+ , settingsWarnings = ["-Wcompat", "-Widentities"]+ , settingsCabal = True+ , settingsStack = True+ , settingsStylish = Just "This is stylish-haskell.yaml\n"+ , settingsContributing = Just "This is contributing guide\n"+ , settingsNoUpload = True+ }+ where+ mitLicense :: License+ mitLicense = License [text|+ MIT License++ Copyright (c) 2018 Kowainik++ Permission is hereby granted, free of charge, to any person obtaining a copy+ of this software and associated documentation files (the "Software"), to deal+ in the Software without restriction, including without limitation the rights+ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+ copies of the Software, and to permit persons to whom the Software is+ furnished to do so, subject to the following conditions:++ The above copyright notice and this permission notice shall be included in all+ copies or substantial portions of the Software.++ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+ IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+ FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+ AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+ LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+ SOFTWARE.+ |]++smallProject :: Settings+smallProject = Settings+ { settingsRepo = "smallProject"+ , settingsOwner = "kowainik"+ , settingsDescription = "Small test project"+ , settingsFullName = "Kowainik"+ , settingsEmail = "xrom.xkov@gmail.com"+ , settingsYear = "2018"+ , settingsCategories = ""+ , settingsLicenseName = None+ , settingsLicenseText = ""+ , settingsGitHub = False+ , settingsPrivate = False+ , settingsTravis = False+ , settingsAppVeyor = False+ , settingsIsLib = False+ , settingsIsExe = True+ , settingsTest = False+ , settingsBench = False+ , settingsTestedVersions = [defaultGHC]+ , settingsBaseType = "base"+ , settingsPrelude = Nothing+ , settingsExtensions = []+ , settingsWarnings = []+ , settingsCabal = True+ , settingsStack = False+ , settingsStylish = Nothing+ , settingsContributing = Nothing+ , settingsNoUpload = True+ }
+ test/Test/QuestionSpec.hs view
@@ -0,0 +1,12 @@+module Test.QuestionSpec+ ( yesNoPromptSpec+ ) where++import Test.Hspec (Spec, describe, it)++import Summoner.Question (YesNoPrompt (..), mkDefaultYesNoPrompt)++yesNoPromptSpec :: Spec+yesNoPromptSpec = describe "mkDefaultYesNoPrompt works correctly" $+ it "makes cabal prompt" $+ yesNoPrompt (mkDefaultYesNoPrompt "Cabal") == "Add Cabal?"
test/Test/TomlSpec.hs view
@@ -1,20 +1,30 @@-module Test.TomlSpec where+module Test.TomlSpec+ ( tomlProp+ ) where -import Hedgehog (MonadGen, forAll, property, tripping)-import Test.Tasty (TestTree)-import Test.Tasty.Hedgehog (testProperty)+import Hedgehog (MonadGen, Property, forAll, property, tripping) import Toml.Bi.Code (decode, encode) import Summoner.Config (ConfigP (..), PartialConfig, configT) import Summoner.GhcVer (GhcVer) import Summoner.License (LicenseName)-import Summoner.ProjectData (CustomPrelude (..))+import Summoner.Settings (CustomPrelude (..)) import Summoner.Source (Source (..)) import Test.DecisionSpec (genDecision) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range ++tomlProp :: Property+tomlProp = property $ do+ configToml <- forAll genPartialConfig+ tripping configToml (encode configT) (decode configT)++----------------------------------------------------------------------------+-- Generators+----------------------------------------------------------------------------+ genText :: MonadGen m => m Text genText = Gen.text (Range.constant 0 10)@@ -27,7 +37,7 @@ genGhcVerArr = Gen.list (Range.constant 0 10) Gen.enumBounded genCustomPrelude :: MonadGen m => m CustomPrelude-genCustomPrelude = Prelude <$> genText <*> genText+genCustomPrelude = CustomPrelude <$> genText <*> genText genLicense :: MonadGen m => m LicenseName genLicense = Gen.element universe@@ -35,7 +45,7 @@ genSource :: MonadGen m => m Source genSource = do txt <- genText- s <- Gen.element [File . toString, Url]+ s <- Gen.element [File . toString, Url, Link] pure $ s txt genPartialConfig :: MonadGen m => m PartialConfig@@ -61,8 +71,3 @@ cStylish <- Last <$> Gen.maybe genSource cContributing <- Last <$> Gen.maybe genSource pure Config{..}--test_Toml :: [TestTree]-test_Toml = pure $ testProperty "decode . encode == id" $ property $ do- configToml <- forAll genPartialConfig- tripping configToml (encode configT) (decode configT)