diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,25 @@ +# Changelog + +`summoner-tui` uses [PVP Versioning][1]. +The changelog is available [on GitHub][2]. + +## 0.1.0 โ€” Apr 9, 2019 + +* Upgrade to `summoner-1.3.0`. +* [#285](https://github.com/kowainik/summoner/issues/285): + Implement `summon script` command. +* [#280](https://github.com/kowainik/summoner/issues/280): + AppVeyor CI checkbox is no longer disabled when only `cabal` build tool is + selected. +* [#297](https://github.com/kowainik/summoner/issues/297): + Strip project description. +* [#304](https://github.com/kowainik/summoner/issues/304): + Bump up to `brick-0.47`. + +## 0.0.0 โ€” Nov 30, 2018 + +* [#208](https://github.com/kowainik/summoner/issues/208): + Implement initial TUI for `summoner`. + +[1]: https://pvp.haskell.org +[2]: https://github.com/kowainik/summoner/releases diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,634 @@ +# ๐Ÿ”ฎ Summoner + +![wizard](https://user-images.githubusercontent.com/8126674/44388234-320aac00-a55a-11e8-879d-5dca68512031.png) +[![Build](https://secure.travis-ci.org/kowainik/summoner.svg)](http://travis-ci.org/kowainik/summoner) +[![Windows build](https://ci.appveyor.com/api/projects/status/github/kowainik/summoner?branch=master&svg=true)](https://ci.appveyor.com/project/kowainik/summoner) +[![Hackage](https://img.shields.io/hackage/v/summoner.svg)](https://hackage.haskell.org/package/summoner) +[![MPL-2.0 license](https://img.shields.io/badge/license-MPL--2.0-blue.svg)](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 a tool for scaffolding fully configured batteries-included production-level Haskell projects. + +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! + +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. + +## Structure + +* [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-) +* [FAQ](#faq-) +* [For Developers](#for-developers-) + + [Build](#build-) + + [Test](#test-) + + [Run](#run-) +* [Changelog](#changelog-) +* [Acknowledgments](#acknowledgments-) + +## Demo [โ†‘](#structure) + +### TUI demo [โ†‘](#structure) + +[![TUI demo](https://asciinema.org/a/214424.png)](https://asciinema.org/a/214424) + +### CLI demo [โ†‘](#structure) + +[![CLI demo](https://asciinema.org/a/214433.png)](https://asciinema.org/a/214433) + +### Scaffolded project structure [โ†‘](#structure) + +This is an example of the project hierarchy you can get if you're running Summoner with all options enabled: + +``` +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 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. ++ Ability to create runnable Haskell scripts. ++ 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 `ghc-options` 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. ++ Guessing user credentials from `.gitconfig`. + +### CI [โ†‘](#structure) + ++ Generation of the `.travis.yml` file that runs build and tests on CI under Linux using + [Dead simple Haskell Travis Settings for Cabal and Stack](https://chshersh.github.io/posts/2019-02-25-haskell-travis). ++ 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 +``` + +##### TUI: 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-tui:exe:summon-tui +``` + +Build and install using `stack`: + +```shell +stack install summoner-tui:exe:summon-tui +``` + +#### Summon-CLI [โ†‘](#structure) + +##### CLI: 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 +``` + +##### CLI: from Hackage/Stackage [โ†‘](#structure) + +Using `cabal`: + +```shell +cabal new-update +cabal new-install summoner +``` + +Using `stack`: + +```shell +stack install summoner +``` + +##### 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. Fields `user.login`, `user.name` and `user.email` from `~/.gitconfig`. +3. Explicitly specified configuration file by `--file FILENAME` option (used instead of the default one if specified). +4. Options that are stated by CLI arguments. +5. 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.6.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? | +| `gitignore` | [Text] | List of files you want added to the default `.gitignore`. (Ignored if `github = false`) | +| `noUpload` | Bool | Do not upload to GitHub, but create all GitHub related files if specified (Ignored if `github = false`) | +| `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`. | +| `ghc-options` | [Text] | List of the default GHC options 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: + +``` +Usage: + summon COMMAND + Set up your own Haskell project + +Available commands: + new Create a new Haskell project + script Create a new Haskell script + show Show available licenses or ghc versions + +Available global options: + -h, --help Show this help text + -v, --version Show summoner's version +``` + +#### **summon new** command: [โ†‘](#structure) + +``` +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]] + +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 + specified '~/.summoner.toml' will be used if present + --prelude-package PACKAGE_NAME + Name for the package of the custom prelude to use in + the project + --prelude-module MODULE_NAME + Name for the module of the custom prelude to use in + the project + +Available commands: + with Specify options to enable + without Specify options to disable + +Available command options: + -h, --help Show this help text + -g, --github Github integration + -p, --private Create private GitHub repository + -c, --travis Travis CI integration + -w, --app-veyor AppVeyor CI integration + -l, --library Library target + -e, --exec Executable target + -t, --test Tests + -b, --benchmark Benchmarks +``` + +#### **summon script** command: [โ†‘](#structure) + +``` +Usage: + summon script BUILD_TOOL [-g|--ghc GHC_VERSION] [-n|--name FILE_NAME] + Create a new Haskell script + +Available options: + -h,--help Show this help text + -g,--ghc GHC_VERSION Version of the compiler to be used for script + -n,--name FILE_NAME Name of the script file +``` + +#### **summon show** command: [โ†‘](#structure) + +``` +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 + +Available options: + -h, --help Show this help text +``` + +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. + +```shell +summon new my-project with -letgcpw without -b --prelude-package relude --prelude-module Relude +``` + +### TUI [โ†‘](#structure) + +#### TUI new command [โ†‘](#structure) + +![summon new TUI](https://user-images.githubusercontent.com/8126674/49283553-fc684e00-f4cc-11e8-8411-f173f5f19a71.png) + +> **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 | +|-----------------------------------|--------------------------------------------------------------------------------------| +| Esc | Abort `summoner` | +| Enter | If input is valid go to the Confirm window | +| Tab | Change the focus to the next active field | +| Shift + Tab | Change the focus to the previous active field | +| Space | Enable/disable current checkbox or radio button | +| Ctrl + d | Delete the input of the current text field | +| Ctrl + u | Delete the input of the current text field from the cursor position to the beginning | +| Ctrl + k | Delete the input of the current text field from the cursor position to the end | +| Ctrl + a | Move the cursor to the beginning of the current input field | +| Ctrl + e | Move the cursor to the end of the current input field | +| Up/Down | 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 script command [โ†‘](#structure) + +See [CLI description](#cli-script-command-) of the `summon script` command. + +#### 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 Enter 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 script command [โ†‘](#structure) + +This command creates minimal `cabal` or `stack` script file which allows you to save some keystrokes and eliminates the need to remember magic words for scripts. + +**Cabal example:** `summon script cabal -n Main.hs` generates executable file `Main.hs` with the following content: + +```haskell +#!/usr/bin/env cabal +{- cabal: +build-depends: + , base ^>= 4.12.0.0 +-} + +main :: IO () +main = putStrLn "Hello, World!" +``` + +**Stack example:** `summon script stack -n Main.hs` generates executable file `Main.hs` with the following content: + +```haskell +#!/usr/bin/env stack +{- stack + --resolver lts-13.16 + script + --package base +-} + +main :: IO () +main = putStrLn "Hello, World!" +``` + +#### 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. + +## FAQ [โ†‘](#structure) + +> I want to use HTTPS remote for the created GitHub project, but it creates SSH one. How should I fix this? + +We are using `hub` tool to create the projects at GitHub. It uses SSH so that you would get the remote links in the following format: + +``` +git@github.com:user/repo.git +``` + +We can not change or configure this behaviour, but there are several workarounds in case you _need_ to use HTTPS link for the remote. + +1. Change the remote of the repository after its creation: + ``` + git remote set-url origin https://github.com/user/repo.git + ``` +2. Change `hub` configurations globally. Simply run the following command: + ```shell + git config --global hub.protocol https + ``` +3. Alternatively, change `hub` configurations for a single session: + ``` + export HUB_PROTOCOL="https" + ``` + +## 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. + +### Dependencies [โ†‘](#structure) + +On Linux, to build the `summoner-tui` you'll need to have `libtinfo` installed. The easiest way to get this is from your system's package manager and is usually available as the package `libtinfo-dev`. + +### Build [โ†‘](#structure) + +To build the project you can use the following commands: + +```shell= +cabal new-build all +``` + +for Cabal and + +```shell= +stack build +``` + +for Stack. + +### Test [โ†‘](#structure) + +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. + +To actually run tests you need to run: + +```shell +cabal new-test all +``` + +or + +```shell +stack test +``` + +### Run [โ†‘](#structure) + +Building Summoner with the recommended method creates two executables: `summon` and `summon-tui`. To run the compiled executable you can use the following commands: + +```shell +cabal new-exec summon -- SOME_COMMAND +cabal new-exec summon-tui -- SOME_COMMAND +``` + +or + +```shell +stack exec summon -- SOME_COMMAND +stack exec summon-tui -- SOME_COMMAND +``` + +## Changelog [โ†‘](#structure) + +Each package has its own changelog: + +* [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. + +Icons made by [Nikita Golubev](https://www.flaticon.com/authors/nikita-golubev) +from [Flaticon](https://www.flaticon.com/) is licensed by +[CC 3.0 BY](http://creativecommons.org/licenses/by/3.0/). diff --git a/app/Tui.hs b/app/Tui.hs new file mode 100644 --- /dev/null +++ b/app/Tui.hs @@ -0,0 +1,8 @@ +module Main where + +import System.IO (hSetEncoding, stdout, utf8) + +import Summoner.Tui (summonTui) + +main :: IO () +main = hSetEncoding stdout utf8 >> summonTui diff --git a/src/Prelude.hs b/src/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Prelude.hs @@ -0,0 +1,10 @@ +-- | Uses [relude](https://hackage.haskell.org/package/relude) as default Prelude. + +module Prelude + ( module Relude + , module Relude.Extra + ) where + +import Relude +import Relude.Extra.Enum as Relude.Extra (universe) +import Relude.Extra.Validation as Relude.Extra diff --git a/src/Summoner/Tui.hs b/src/Summoner/Tui.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Tui.hs @@ -0,0 +1,347 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ViewPatterns #-} + +{- | This is experimental module. + +We are trying to make the TUI app for summoner, but it's WIP. +-} + +module Summoner.Tui + ( summonTui + ) where + +import Brick (App (..), AttrMap, BrickEvent (..), Widget, attrMap, continue, customMain, halt, + simpleApp, str, txt, vBox, withAttr, (<+>)) +import Brick.Focus (focusRingCursor) +import Brick.Forms (allFieldsValid, focusedFormInputAttr, formFocus, formState, handleFormEvent, + invalidFormInputAttr, renderForm) +import Brick.Main (ViewportScroll, neverShowCursor, vScrollBy, viewportScroll) +import Brick.Types (EventM, Next, ViewportType (Vertical)) +import Brick.Util (fg) +import Brick.Widgets.Border (borderAttr) +import Brick.Widgets.Center (center) +import Brick.Widgets.Core (emptyWidget, fill, hLimit, hLimitPercent, padTopBottom, strWrap, txtWrap, + vLimit, viewport) +import Brick.Widgets.Edit (editAttr, editFocusedAttr) +import Brick.Widgets.List (listSelectedAttr, listSelectedFocusedAttr) +import Lens.Micro ((.~), (^.)) +import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, listDirectory) + +import Summoner.Ansi (errorMessage, infoMessage) +import Summoner.CLI (Command (..), NewOpts (..), ShowOpts (..), getFinalConfig, runScript, summon) +import Summoner.Decision (Decision (..)) +import Summoner.Default (defaultConfigFile) +import Summoner.GhcVer (showGhcVer) +import Summoner.License (License (..), LicenseName, fetchLicense, parseLicenseName, + showLicenseWithDesc) +import Summoner.Project (initializeProject) +import Summoner.Tui.Field (disabledAttr) +import Summoner.Tui.Form (KitForm, SummonForm (..), getCurrentFocus, isActive, mkForm, recreateForm) +import Summoner.Tui.Kit +import Summoner.Tui.Validation (ctrlD, formErrorMessages, summonFormValidation) +import Summoner.Tui.Widget (borderLabel, listInBorder) + +import qualified Brick (on) +import qualified Graphics.Vty as V +import qualified Paths_summoner_tui as Meta (version) + + +-- | Main function that parses @CLI@ arguments and runs @summoner@ in TUI mode. +summonTui :: IO () +summonTui = summon Meta.version runTuiCommand + +-- | Run TUI specific to each command. +runTuiCommand :: Command -> IO () +runTuiCommand = \case + New opts -> summonTuiNew opts + Script opts -> runScript opts -- TODO: implement TUI for script command + ShowInfo opts -> summonTuiShow opts + +---------------------------------------------------------------------------- +-- New command +---------------------------------------------------------------------------- + +{- | TUI for creating new project. Contains interactive elements like text input +fields or checkboxes to configure settings for new project. +-} +summonTuiNew :: NewOpts -> IO () +summonTuiNew newOpts@NewOpts{..} = do + -- configure initial state for TUI application + finalConfig <- getFinalConfig newOpts + configFilePath <- findConfigFile + let initialKit = configToSummonKit + newOptsProjectName + newOptsOffline + configFilePath + finalConfig + + -- run TUI app + skForm <- runTuiNew initialKit + + -- perform actions depending on the final state + let kit = formState skForm + if allFieldsValid skForm && (kit ^. shouldSummon == Yes) + then finalSettings kit >>= initializeProject + else errorMessage "Aborting summoner" + where + findConfigFile :: IO (Maybe FilePath) + findConfigFile = if newOptsIgnoreFile + then pure Nothing + else case newOptsConfigFile of + Nothing -> defaultConfigFile >>= \file -> + ifM (doesFileExist file) (pure $ Just file) (pure Nothing) + justFile -> pure justFile + +-- | Check content of current directory and create form after forming 'SummonKit'. +runTuiNew :: SummonKit -> IO (KitForm e) +runTuiNew kit = do + filesAndDirs <- listDirectory =<< getCurrentDirectory + dirs <- filterM doesDirectoryExist filesAndDirs + runApp (appNew dirs) (summonFormValidation dirs $ mkForm kit) + +-- | Represents @new@ command app behaviour. +appNew :: [FilePath] -> App (KitForm e) e SummonForm +appNew dirs = App + { appDraw = drawNew dirs + , appHandleEvent = \s ev -> if formState s ^. shouldSummon == Idk + then case ev of + VtyEvent (V.EvKey V.KEnter []) -> halt $ changeShouldSummon Yes s + VtyEvent (V.EvKey V.KEsc []) -> withForm ev s (changeShouldSummon Nop) + _ -> continue s + else case ev of + VtyEvent V.EvResize {} -> continue s + VtyEvent (V.EvKey V.KEnter []) -> + if allFieldsValid s + then withForm ev s (changeShouldSummon Idk) + else continue s + VtyEvent (V.EvKey V.KEsc []) -> halt s + VtyEvent (V.EvKey (V.KChar 'd') [V.MCtrl]) -> + withForm ev s (validateForm . ctrlD) + + -- Handle active/inactive checkboxes + VtyEvent (V.EvKey (V.KChar ' ') []) -> case getCurrentFocus s of + Nothing -> withFormDef ev s + Just field -> handleCheckboxActivation ev s field + MouseDown n _ _ _ -> handleCheckboxActivation ev s n + + -- Handle skip of deactivated checkboxes + VtyEvent (V.EvKey (V.KChar '\t') []) -> loopWhileInactive ev s + VtyEvent (V.EvKey V.KBackTab []) -> loopWhileInactive ev s + + -- Default action + _ -> withFormDef ev s + + , appChooseCursor = focusRingCursor formFocus + , appStartEvent = pure + , appAttrMap = const theMap + } + where + withForm ev s f = handleFormEvent ev s >>= continue . f + withFormDef ev s = withForm ev s validateForm + + changeShouldSummon :: Decision -> KitForm e -> KitForm e + changeShouldSummon newShould f = mkForm $ formState f & shouldSummon .~ newShould + + validateForm :: KitForm e -> KitForm e + validateForm = summonFormValidation dirs + + mkNewForm :: KitForm e -> KitForm e + mkNewForm = recreateForm validateForm + + -- Activate/Deactivate checkboxes depending on current field change + handleCheckboxActivation + :: BrickEvent SummonForm e + -> KitForm e + -> SummonForm + -> EventM SummonForm (Next (KitForm e)) + handleCheckboxActivation ev form = \case + StackField -> withForm ev form mkNewForm + GitHubEnable -> withForm ev form mkNewForm + GitHubDisable -> withForm ev form mkNewForm + GitHubNoUpload -> withForm ev form mkNewForm + _ -> withFormDef ev form + + -- Handles form event until current element is active + loopWhileInactive + :: BrickEvent SummonForm e + -> KitForm e + -> EventM SummonForm (Next (KitForm e)) + loopWhileInactive ev form = do + newForm <- handleFormEvent ev form + case getCurrentFocus newForm of + Nothing -> continue newForm + Just field -> if not $ isActive (formState newForm) field + then loopWhileInactive ev newForm + else continue newForm + +-- | Draws the form for @new@ command. +drawNew :: [FilePath] -> KitForm e -> [Widget SummonForm] +drawNew dirs kitForm = case kit ^. shouldSummon of + Idk -> [confirmDialog] + _ -> [formWidget] + where + kit :: SummonKit + kit = formState kitForm + + confirmDialog :: Widget SummonForm + confirmDialog = center $ hLimit 55 $ borderLabel "Confirm" $ padTopBottom 2 $ vBox + [ str "โ€ข Enter โ€“ Press Enter to create the project" + , str "โ€ข Esc โ€“ Or Esc to go back to settings" + ] + + formWidget :: Widget SummonForm + formWidget = vBox + [ form <+> tree + , status <+> help + ] + + form :: Widget SummonForm + form = borderLabel "Summon new project" (renderForm kitForm) + + tree :: Widget SummonForm + tree = hLimitPercent 25 $ vLimit 21 $ borderLabel "Project Structure" $ vBox + [ withAttr "tree" $ txt $ renderWidgetTree kit + -- to fill all the space that widget should take. + , fill ' ' + ] + + status :: Widget SummonForm + status = hLimitPercent 45 $ + borderLabel "Status" $ vBox + [ informationBlock + , validationBlock + , configBlock + , fill ' ' + ] + where + informationBlock :: Widget SummonForm + informationBlock = case getCurrentFocus kitForm of + Just UserOwner -> infoTxt "GitHub username" + Just ProjectCat -> infoTxt "Comma-separated categories as used at Hackage" + Just Ghcs -> infoTxt "Space separated GHC versions" + _ -> emptyWidget + + infoTxt :: Text -> Widget SummonForm + infoTxt = withAttr "blue-fg" . txtWrap . (<>) " โ“˜ " + + validationBlock :: Widget SummonForm + validationBlock = vBox $ case formErrorMessages dirs kitForm of + [] -> [withAttr "green-fg" $ str " โœ” Project configuration is valid"] + fields -> map (\msg -> withAttr "red-fg" $ strWrap $ " โ˜“ " ++ msg) fields + + configBlock :: Widget SummonForm + configBlock = case kit ^. configFile of + Nothing -> emptyWidget + Just file -> infoTxt $ toText file <> " file is used" + + help, helpBody :: Widget SummonForm + help = borderLabel "Help" (helpBody <+> fill ' ') + helpBody = vBox + [ str "โ€ข Enter : create the project" + , str "โ€ข Esc : quit" + , str "โ€ข Ctrl+d : remove input of the text field" + , str "โ€ข Arrows : up/down arrows to choose license" + ] + +---------------------------------------------------------------------------- +-- Show command +---------------------------------------------------------------------------- + +-- | Simply shows info about GHC versions or licenses in TUI. +summonTuiShow :: ShowOpts -> IO () +summonTuiShow = \case + GhcList -> runTuiShowGhcVersions + LicenseList Nothing -> runTuiShowAllLicenses + LicenseList (Just name) -> runTuiShowLicense name + +runTuiShowGhcVersions :: IO () +runTuiShowGhcVersions = runSimpleApp drawGhcVersions + where + drawGhcVersions :: Widget () + drawGhcVersions = listInBorder "Supported GHC versions" 30 0 (map showGhcVer universe) + +runTuiShowAllLicenses :: IO () +runTuiShowAllLicenses = runSimpleApp drawLicenseNames + where + drawLicenseNames :: Widget () + drawLicenseNames = listInBorder "Supported licenses" 70 4 (map showLicenseWithDesc universe) + +runTuiShowLicense :: String -> IO () +runTuiShowLicense (toText -> name) = case parseLicenseName name of + Nothing -> do + errorMessage $ "Error parsing license name: " <> name + infoMessage "Use 'summon show license' command to see the list of all available licenses" + Just licenseName -> do + lc <- fetchLicense licenseName + runApp (licenseApp licenseName lc) () + where + licenseApp :: LicenseName -> License -> App () e () + licenseApp licenseName lc = App + { appDraw = drawScrollableLicense licenseName lc + , appStartEvent = pure + , appAttrMap = const theMap + , appChooseCursor = neverShowCursor + , appHandleEvent = \() event -> case event of + VtyEvent (V.EvKey V.KDown []) -> vScrollBy licenseScroll 1 >> continue () + VtyEvent (V.EvKey V.KUp []) -> vScrollBy licenseScroll (-1) >> continue () + VtyEvent (V.EvKey V.KEsc []) -> halt () + _ -> continue () + } + + licenseScroll :: ViewportScroll () + licenseScroll = viewportScroll () + + drawScrollableLicense :: LicenseName -> License -> () -> [Widget ()] + drawScrollableLicense licenseName (License lc) = const [ui] + where + ui :: Widget () + ui = center + $ hLimit 80 + $ borderLabel ("License: " ++ show licenseName) + $ viewport () Vertical + $ vBox + $ map (\t -> if t == "" then txt "\n" else txtWrap t) + $ lines lc + +---------------------------------------------------------------------------- +-- Internal +---------------------------------------------------------------------------- + +-- | Runs brick application with given start state. +runApp :: Ord n => App s e n -> s -> IO s +runApp app s = do + initialVty <- buildVty + customMain initialVty buildVty Nothing app s + where + buildVty :: IO V.Vty + buildVty = do + v <- V.mkVty =<< V.standardIOConfig + V.setMode (V.outputIface v) V.Mouse True + pure v + +-- | Runs the app without any state. +runSimpleApp :: Ord n => Widget n -> IO () +runSimpleApp w = runApp (mkSimpleApp w) () + +-- | Creates simple brick app that doesn't have state and just displays given 'Widget'. +mkSimpleApp :: Widget n -> App () e n +mkSimpleApp w = (simpleApp w) + { appAttrMap = const theMap + } + +-- | Styles, colours that are used across the app. +theMap :: AttrMap +theMap = attrMap V.defAttr + [ (editAttr, V.black `Brick.on` V.cyan) + , (editFocusedAttr, V.black `Brick.on` V.white) + , (invalidFormInputAttr, V.white `Brick.on` V.red) + , (focusedFormInputAttr, V.black `Brick.on` V.yellow) + , (listSelectedAttr, V.black `Brick.on` V.cyan) + , (listSelectedFocusedAttr, V.black `Brick.on` V.white) + , (disabledAttr, fg V.brightBlack) + , ("blue-fg", fg V.blue) + , ("green-fg", fg V.green) + , ("red-fg", fg V.brightRed) + , (borderAttr, fg V.cyan) + , ("tree", fg V.cyan) + ] diff --git a/src/Summoner/Tui/Field.hs b/src/Summoner/Tui/Field.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Tui/Field.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE Rank2Types #-} + +{- | This modules adds necessary functions for Forms and Form fields +that are not covered in @brick@ library. +-} + +module Summoner.Tui.Field + ( strField + , checkboxField + , activeCheckboxField + , radioField + , disabledAttr + ) where + +import Brick (BrickEvent (..), EventM, Location (..), Widget, clickable, showCursor, str, vBox, + withAttr, withDefAttr, (<+>)) +import Brick.AttrMap (AttrName) +import Brick.Forms (FormField (..), FormFieldState (..), checkboxCustomField, focusedFormInputAttr, + radioCustomField) +import Lens.Micro (Lens', lens, (^.)) + +import qualified Graphics.Vty as V + + +-- | A form field with a given text value which can not be modified or changed +-- via any events. It is always valid. +strField :: forall s e n . String -> s -> FormFieldState s e n +strField t _ = FormFieldState + { formFieldState = () + , formFieldLens = fakeLens + , formFields = [] + , formFieldRenderHelper = renderString + , formFieldConcat = vBox + } + where + -- looool + fakeLens :: Lens' s () + fakeLens = lens (const ()) (\s () -> s) + + renderString :: Widget n -> Widget n + renderString w = str t <+> w + +{- | Custom checkbox with unique fancy style. + +__Example:__ + +@ +โŸฆโœ”โŸง Library +โŸฆ โŸง Executable +@ +-} +checkboxField + :: (Ord n, Show n) + => Lens' s Bool -- ^ The state lens for this value. + -> n -- ^ The resource name for the input field. + -> Text -- ^ The label for the check box, to appear at its right. + -> s -- ^ The initial form state. + -> FormFieldState s e n +checkboxField = checkboxCustomField 'โŸฆ' 'โœ”' 'โŸง' + +{- | Custom radio button with unique fancy style. + +__Example:__ + +@ +โฎโ—†โฏ Enable โฎ โฏ Disable +@ +-} +radioField + :: (Ord n, Show n, Eq a) + => Lens' s a -- ^ The state lens for this value. + -> [(a, n, Text)] -- ^ The available choices, in order. + -> s -- ^ The initial form state. + -> FormFieldState s e n +radioField = radioCustomField 'โฎ' 'โ—†' 'โฏ' + +-- | Checkbox that can be disabled. +activeCheckboxField + :: forall n s e . Ord n + => Lens' s Bool + -> (s -> n -> Bool) -- ^ Function should return 'False' if checkbox should be disabled. + -> n + -> String -- ^ The label for the check box, to appear at its right. + -> s -- ^ The initial form state. + -> FormFieldState s e n +activeCheckboxField stLens isActive name label initialState = FormFieldState + { formFieldState = initVal + , formFields = [checkboxFormField] + , formFieldLens = stLens + , formFieldRenderHelper = id + , formFieldConcat = vBox + } + where + initVal, isEnabled :: Bool + initVal = initialState ^. stLens + isEnabled = isActive initialState name + + handleEvent :: BrickEvent n e -> Bool -> EventM n Bool + handleEvent (MouseDown n _ _ _) + | isEnabled && n == name = pure . not + handleEvent (VtyEvent (V.EvKey (V.KChar ' ') [])) = pure . not + handleEvent _ = pure + + checkboxFormField :: FormField Bool Bool e n + checkboxFormField = FormField + { formFieldName = name + , formFieldValidate = Just + , formFieldExternallyValid = True + , formFieldRender = renderCheckbox isEnabled label name + , formFieldHandleEvent = handleEvent + } + +-- | Renders checkbox depending on its state. +renderCheckbox :: Bool -> String -> n -> Bool -> Bool -> Widget n +renderCheckbox isEnabled label n foc val = + let addAttr = if foc then withDefAttr focusedFormInputAttr else id + csr = if foc then showCursor n (Location (1,0)) else id + in if isEnabled + then clickable n $ addAttr $ csr $ str $ + "โŸฆ" <> (if val then "โœ”" else " ") <> "โŸง" <> " " <> label + else withAttr disabledAttr $ str $ "โŸฆ โŸง " <> label + +-- | Attribute for disabled checkboxes. +disabledAttr :: AttrName +disabledAttr = "disabled" diff --git a/src/Summoner/Tui/Form.hs b/src/Summoner/Tui/Form.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Tui/Form.hs @@ -0,0 +1,162 @@ +-- | Form layout and form fields data types. + +module Summoner.Tui.Form + ( SummonForm (..) + , KitForm + , mkForm + , getCurrentFocus + , isActive + , recreateForm + ) where + +import Brick (Padding (Max), Widget, hBox, padRight, str, txt, vBox, vLimit) +import Brick.Focus (focusGetCurrent) +import Brick.Forms (Form, editField, editTextField, formFocus, formState, listField, newForm, + setFieldConcat, setFormConcat, setFormFocus, (@@=)) +import Lens.Micro ((^.)) + +import Summoner.Default (defaultGHC) +import Summoner.GhcVer (parseGhcVer, showGhcVer) +import Summoner.License (LicenseName) +import Summoner.Text (intercalateMap) +import Summoner.Tui.Field (activeCheckboxField, checkboxField, radioField, strField) +import Summoner.Tui.GroupBorder (groupBorder, (|>)) +import Summoner.Tui.Kit +import Summoner.Tui.Widget (borderLabel, hArrange, label) + +import qualified Brick.Widgets.Center as C +import qualified Data.Text as T + + +-- | Form that is used for @new@ command. +data SummonForm + -- User + = UserOwner + | UserFullName + | UserEmail + + -- Project + | ProjectName + | ProjectDesc + | ProjectCat + | ProjectLicense + + -- Build tools + | CabalField + | StackField + + -- Project Meta + | Lib + | Exe + | Test + | Bench + | CustomPreludeName + | CustomPreludeModule + | Ghcs + + -- GitHub fields + | GitHubEnable + | GitHubDisable + | GitHubNoUpload + | GitHubPrivate + | GitHubTravis + | GitHubAppVeyor + deriving (Show, Eq, Ord, Enum, Bounded) + +-- | Alias for type of the @summoner@ form. +type KitForm e = Form SummonKit e SummonForm + +-- | Creates the input form from the given initial 'SummonKit'. +mkForm :: forall e . SummonKit -> KitForm e +mkForm sk = setFormConcat arrangeColumns $ newForm + ( groupBorder "User" + [ 2 |> label "Owner " @@= editTextField (user . owner) UserOwner (Just 1) + , 1 |> label "Full name " @@= editTextField (user . fullName) UserFullName (Just 1) + , 2 |> label "Email " @@= editTextField (user . email) UserEmail (Just 1) + ] + ++ groupBorder "Project" + [ 2 |> label "Name " @@= editTextField (project . repo) ProjectName (Just 1) + , 3 |> label "Description " @@= editTextField (project . desc) ProjectDesc (Just 2) + , 2 |> label "Category " @@= editTextField (project . category) ProjectCat (Just 1) + , 4 |> vLimit 3 . label "License " @@= listField (const (fromList $ universe @LicenseName)) + maybeLicense widgetList 1 ProjectLicense + ] + -- ++ groupBorder "Tools" + -- [ 2 |> checkboxField cabal CabalField "Cabal" + -- , 2 |> checkboxField stack StackField "Stack" + -- ] + ++ [ checkboxField cabal CabalField "Cabal" + , checkboxField stack StackField "Stack" + ] + + ++ groupBorder "Project Meta" + [ 2 |> checkboxField (projectMeta . lib) Lib "Library" + , 1 |> checkboxField (projectMeta . exe) Exe "Executable" + , 1 |> checkboxField (projectMeta . test) Test "Tests" + , 2 |> checkboxField (projectMeta . bench) Bench "Benchmarks" + , 1 |> strField "Custom prelude" + , 1 |> label "Name " @@= editTextField (projectMeta . preludeName) CustomPreludeName (Just 1) + , 2 |> label "Module " @@= editTextField (projectMeta . preludeModule) CustomPreludeModule (Just 1) + , 2 |> label ("GHC versions: " <> toString (showGhcVer defaultGHC) <> " ") @@= + editField + (projectMeta . ghcs) + Ghcs + (Just 1) + (intercalateMap " " showGhcVer) + (traverse parseGhcVer . words . T.intercalate " ") + (txt . T.intercalate "\n") + id + ] + ++ groupBorder "GitHub" + [ 2 |> setFieldConcat hArrange . radioField (gitHub . enabled) + [ (True, GitHubEnable, "Enable") + , (False, GitHubDisable, "Disable") + ] + , 1 |> activeCheckboxField (gitHub . noUpload) isActive GitHubNoUpload "No upload" + , 1 |> activeCheckboxField (gitHub . private) isActive GitHubPrivate "Private" + , 1 |> activeCheckboxField (gitHub . travis) isActive GitHubTravis "Travis" + , 2 |> activeCheckboxField (gitHub . appVeyor) isActive GitHubAppVeyor "AppVeyor" + ] + ) sk + where + widgetList :: Bool -> LicenseName -> Widget SummonForm + widgetList p l = C.hCenter $ str $ if p then "[" ++ show l ++ "]" else show l + + arrangeColumns :: [Widget SummonForm] -> Widget SummonForm + arrangeColumns widgets = + let (column1, columns2) = splitAt 7 widgets in + let (tools, column2) = splitAt 2 columns2 in + hBox [ vBox $ column1 ++ [borderLabel "Tools" $ padRight Max (hArrange tools)] + , vBox column2 + ] + +-- | Returns 'True' when form field is active depending on the current state of 'SummonKit'. +isActive :: SummonKit -> SummonForm -> Bool +isActive kit = \case + GitHubNoUpload -> isGitHubEnabled + GitHubPrivate -> isGitHubEnabled && isUploadEnabled + GitHubTravis -> isGitHubEnabled + GitHubAppVeyor -> isGitHubEnabled + _ -> True + where + isGitHubEnabled, isUploadEnabled :: Bool + isGitHubEnabled = kit ^. gitHub . enabled + isUploadEnabled = not $ kit ^. gitHub . noUpload + +-- | Gets current focus of the form. +getCurrentFocus :: Form s e n -> Maybe n +getCurrentFocus = focusGetCurrent . formFocus + +{- | Create form from scratch using its current state. This is needed to +activate/deactivate checkboxes. Should be done with care to preserve focus and +fields validation. +-} +recreateForm + :: forall e . + (KitForm e -> KitForm e) -- ^ Validation function + -> KitForm e -- ^ Original form + -> KitForm e -- ^ New form +recreateForm validate kitForm = setFocus $ validate $ mkForm $ formState kitForm + where + setFocus :: KitForm e -> KitForm e + setFocus = maybe id setFormFocus (getCurrentFocus kitForm) diff --git a/src/Summoner/Tui/GroupBorder.hs b/src/Summoner/Tui/GroupBorder.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Tui/GroupBorder.hs @@ -0,0 +1,94 @@ +{- | +@Brick@ library helper functions to group checkbox elements inside the form. +This is not going to be the part of the library itself, so we will have it in +our own libraries. See relevant discussion under the corresponding issue: + +* https://github.com/jtdaugherty/brick/issues/190 + +-} + +module Summoner.Tui.GroupBorder + ( groupBorder + , (|>) + ) where + +import Brick (Edges (..), Padding (Max), Widget, padRight, vLimit, (<+>), (<=>)) +import Brick.Forms (FormFieldState, (@@=)) +import Brick.Widgets.Border (hBorder, hBorderWithLabel, joinableBorder, vBorder) + +import Summoner.Tui.Widget (borderLabel, borderName) + + +-- | Create a pair of elements. +infix 4 |> +(|>) :: Int -> a -> (Int, a) +(|>) = (,) +{-# INLINE (|>) #-} + + +{- | +This function unites any amount of the form elements under the one group in +bourders with the given group name. Intended to be used for joining check-boxes +together, but any other elemens of the form will work the same way. +__Example:__ +@ +โ”Œโ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€Formโ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ” +โ”‚ โ”‚ +โ”‚โ”Œโ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€Accountsโ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”โ”‚ +โ”‚โ”‚[ ] user1 โ”‚โ”‚ +โ”‚โ”‚[ ] User2 โ”‚โ”‚ +โ”‚โ””โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”˜โ”‚ +โ””โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”˜ +@ +**Note:** on an empty list it doesn't create any group or border. +-} +groupBorder :: String -> [(Int, s -> FormFieldState s e n)] -> [s -> FormFieldState s e n] +groupBorder groupName = \case + [] -> [] + [x] -> [groupAllBorders groupName x] + (x:y:xs) -> let (mid, l) = (init $ y :| xs, last $ y :| xs) in + groupBorderTop groupName x : map groupBorderMid mid ++ [groupBorderBottom l] + +-- | Creates the top border with the group name. +groupBorderTop :: String -> (Int, s -> FormFieldState s e n) -> (s -> FormFieldState s e n) +groupBorderTop groupName (i, f) = + ( vLimit i + . ((tl <=> vBorder) <+>) + . (<+> (tr <=> vBorder)) + . (hBorderWithLabel (borderName groupName) <=>) + ) @@= f + +-- | Creates the bottom border of the group. +groupBorderBottom :: (Int, s -> FormFieldState s e n) -> (s -> FormFieldState s e n) +groupBorderBottom (i, f) = + ( vLimit i + . ((vBorder <=> bl) <+>) + . (<+> (vBorder <=> br)) + . (<=> hBorder) + . padRight Max + ) @@= f + +-- | Creates the left and right borders for the middle elements of the group. +groupBorderMid :: (Int, s -> FormFieldState s e n) -> (s -> FormFieldState s e n) +groupBorderMid (i, f) = + ( vLimit i + . (vBorder <+>) + . (<+> vBorder) + . padRight Max + ) @@= f + +-- | Creates the border around the only one element. +groupAllBorders :: String -> (Int, s -> FormFieldState s e n) -> (s -> FormFieldState s e n) +groupAllBorders groupName (i, f) = + ( vLimit i + . borderLabel groupName + . padRight Max + ) @@= f + + +-- | Helpers for the correct border lines. +tl, tr, bl, br :: Widget n +tl = joinableBorder (Edges False True False True) +tr = joinableBorder (Edges False True True False) +bl = joinableBorder (Edges True False False True) +br = joinableBorder (Edges True False True False) diff --git a/src/Summoner/Tui/Kit.hs b/src/Summoner/Tui/Kit.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Tui/Kit.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | This module contains data types to work with application form. +'SummonKit' is the data type containing the values manipulated by the fields +in the form. +-} + +module Summoner.Tui.Kit + ( -- * Data types + SummonKit (..) + , User (..) + , Project (..) + , ProjectMeta (..) + , GitHub (..) + , renderWidgetTree + , configToSummonKit + , finalSettings + + -- * Lenses + -- ** SummonKit + , user + , project + , cabal + , stack + , projectMeta + , gitHub + , extensions + , ghcOptions + , stylish + , contributing + , offline + , shouldSummon + , configFile + + -- ** User + , owner + , fullName + , email + + -- ** Project + , repo + , desc + , category + , license + , maybeLicense + + -- ** ProjectMeta + , lib + , exe + , test + , bench + , ghcs + , preludeName + , preludeModule + + -- ** GitHub + , enabled + , noUpload + , private + , travis + , appVeyor + ) where + +import Lens.Micro (Lens', lens, (.~), (^.)) +import Lens.Micro.TH (makeFields) + +import Summoner.Config (Config, ConfigP (..)) +import Summoner.Decision (Decision (..)) +import Summoner.Default (currentYear, defaultDescription, defaultGHC) +import Summoner.GhcVer (GhcVer) +import Summoner.License (LicenseName (..), customizeLicense, fetchLicense) +import Summoner.Settings (CustomPrelude (..), Settings (..)) +import Summoner.Source (Source, fetchSource) +import Summoner.Template (createProjectTemplate) +import Summoner.Tree (showTree) + +import qualified Data.List as List (delete) +import qualified Data.Text as T + + +-- | Global TUI state. +data SummonKit = SummonKit + { summonKitUser :: !User + , summonKitProject :: !Project + , summonKitCabal :: !Bool + , summonKitStack :: !Bool + , summonKitProjectMeta :: !ProjectMeta + , summonKitGitHub :: !GitHub + , summonKitExtensions :: ![Text] -- ^ Can be recieved from the config file. + , summonKitGhcOptions :: ![Text] -- ^ Can be recieved from the config file. + , summonKitGitignore :: ![Text] -- ^ Received from the config file. + , summonKitStylish :: !(Maybe Source) -- ^ Can be recieved from the config file. + , summonKitContributing :: !(Maybe Source) -- ^ Can be recieved from the config file. + , summonKitOffline :: !Bool + , summonKitShouldSummon :: !Decision -- ^ Check if project needs to be created. + , summonKitConfigFile :: !(Maybe FilePath) -- ^ Just if configuration file was used. + } deriving (Show) + +-- | User information. +data User = User + { userOwner :: !Text -- ^ GitHub user or organization name. + , userFullName :: !Text + , userEmail :: !Text + } deriving (Show) + +-- | Project related information +data Project = Project + { projectRepo :: !Text -- ^ Project name. + , projectDesc :: !Text -- ^ Short project description. + , projectCategory :: !Text -- ^ Comma-separated. See @Hackage@ for existing category list. + , projectLicense :: !LicenseName + } deriving (Show) + +-- | Project meta information. +data ProjectMeta = ProjectMeta + { projectMetaLib :: !Bool + , projectMetaExe :: !Bool + , projectMetaTest :: !Bool + , projectMetaBench :: !Bool + , projectMetaGhcs :: ![GhcVer] -- ^ Default GHC version is always added. + , projectMetaPreludeName :: !Text + , projectMetaPreludeModule :: !Text + } deriving (Show) + +-- | Github specific information. +data GitHub = GitHub + { gitHubEnabled :: !Bool + , gitHubNoUpload :: !Bool -- ^ Do not upload to GitHub, only local initialization. + , gitHubPrivate :: !Bool + , gitHubTravis :: !Bool + , gitHubAppVeyor :: !Bool + } deriving (Show) + +makeFields ''SummonKit +makeFields ''User +makeFields ''Project +makeFields ''ProjectMeta +makeFields ''GitHub + +-- | Lens for 'Maybe' 'LicenseName' in 'SummonKit'. +maybeLicense :: Lens' SummonKit (Maybe LicenseName) +maybeLicense = lens getL setL + where + getL :: SummonKit -> Maybe LicenseName + getL = Just . projectLicense . summonKitProject + + setL :: SummonKit -> Maybe LicenseName -> SummonKit + setL sk mbL = case mbL of + Just l -> sk & project . license .~ l + Nothing -> sk + +-- | Converts 'SummonKit' to main 'Settings' data type. +summonKitToSettings :: SummonKit -> Settings +summonKitToSettings sk = Settings + { settingsRepo = T.strip $ sk ^. project . repo + , settingsOwner = T.strip $ sk ^. user . owner + , settingsDescription = T.strip $ sk ^. project . desc + , settingsFullName = T.strip $ sk ^. user . fullName + , settingsEmail = T.strip $ sk ^. user . email + , settingsYear = "20!8" + , settingsCategories = T.strip $ sk ^. project . category + , settingsLicenseName = sk ^. project . license + , settingsLicenseText = "" + , settingsGitHub = isGitHub + , settingsPrivate = isGitHub && sk ^. gitHub . private + , settingsTravis = isGitHub && sk ^. gitHub . travis + , settingsAppVeyor = isGitHub && sk ^. gitHub . appVeyor && sk ^. stack + , settingsIsLib = sk ^. projectMeta . lib + , settingsIsExe = sk ^. projectMeta . exe + , settingsTest = sk ^. projectMeta . test + , settingsBench = sk ^. projectMeta . bench + , settingsTestedVersions = sortNub $ defaultGHC : (sk ^. projectMeta . ghcs) + , settingsBaseType = baseT + , settingsPrelude = cP + , settingsExtensions = sk ^. extensions + , settingsGhcOptions = sk ^. ghcOptions + , settingsGitignore = sk ^. gitignore + , settingsCabal = sk ^. cabal + , settingsStack = sk ^. stack + , settingsStylish = "" <$ sk ^. stylish + , settingsContributing = "" <$ sk ^. contributing + , settingsNoUpload = sk ^. gitHub . noUpload + } + where + isGitHub :: Bool + isGitHub = sk ^. gitHub . enabled + + baseT :: Text + cP :: Maybe CustomPrelude + (baseT, cP) = + let cpPackage = T.strip $ sk ^. projectMeta . preludeName + cpModule = T.strip $ sk ^. projectMeta . preludeModule + in if ("" /= cpPackage) && ("" /= cpModule) + then ("base-noprelude", Just CustomPrelude{..}) + else ("base", Nothing) + +-- | Gets 'Settings' on successful application complition. +finalSettings :: SummonKit -> IO Settings +finalSettings sk = do + year <- currentYear + let licenseName = sk ^. project . license + fetchedLicense <- fetchLicense licenseName + let licenseText = customizeLicense + licenseName + fetchedLicense + (sk ^. user . fullName) + year + + let fetch = maybe (pure Nothing) (fetchSource (sk ^. offline)) + sStylish <- fetch $ sk ^. stylish + sContributing <- fetch $ sk ^. contributing + + pure (summonKitToSettings sk) + { settingsYear = year + , settingsLicenseText = licenseText + , settingsStylish = sStylish + , settingsContributing = sContributing + } + +-- | Gets the initial 'SummonKit' from the given 'Config'. +configToSummonKit + :: Text -- ^ Given project name + -> Bool -- ^ @offline@ mode option + -> Maybe FilePath -- ^ Configuration file used + -> Config -- ^ Given configurations. + -> SummonKit +configToSummonKit cRepo cOffline cConfigFile Config{..} = SummonKit + { summonKitUser = User + { userOwner = cOwner + , userFullName = cFullName + , userEmail = cEmail + } + , summonKitProject = Project + { projectRepo = cRepo + , projectDesc = defaultDescription + , projectCategory = "" + , projectLicense = if cOffline then None else cLicense + } + , summonKitProjectMeta = ProjectMeta + { projectMetaLib = kitLib + , projectMetaExe = kitExe + , projectMetaTest = toBool cTest + , projectMetaBench = toBool cBench + , projectMetaGhcs = List.delete defaultGHC cGhcVer + , projectMetaPreludeName = kitPreludeName + , projectMetaPreludeModule = kitPreludeModule + } + , summonKitCabal = kitCabal + , summonKitStack = kitStack + , summonKitGitHub = GitHub + { gitHubEnabled = cGitHub /= Nop + , gitHubNoUpload = getAny cNoUpload || cOffline + , gitHubPrivate = toBool cPrivate + , gitHubTravis = (cGitHub /= Nop) && (cTravis /= Nop) + , gitHubAppVeyor = toBool cAppVey && kitStack + } + , summonKitExtensions = cExtensions + , summonKitGhcOptions = cWarnings ++ cGhcOptions + , summonKitGitignore = cGitignore + , summonKitStylish = getLast cStylish + , summonKitContributing = getLast cContributing + , summonKitOffline = cOffline + , summonKitShouldSummon = Nop + , summonKitConfigFile = cConfigFile + } + where + kitCabal, kitStack, kitLib, kitExe :: Bool + (kitCabal, kitStack) = decToBools (cCabal, cStack) + (kitLib, kitExe) = decToBools (cLib, cExe) + + decToBools :: (Decision, Decision) -> (Bool, Bool) + decToBools = \case + (Idk, Idk) -> (True, True) + (Yes, Idk) -> (True, False) + (Idk, Yes) -> (False, True) + (Nop, Idk) -> (False, True) + (Idk, Nop) -> (True, False) + (x, y) -> (toBool x, toBool y) + + toBool :: Decision -> Bool + toBool = \case + Yes -> True + Nop -> False + Idk -> False + + kitPreludeName, kitPreludeModule :: Text + (kitPreludeName, kitPreludeModule) = case getLast cPrelude of + Nothing -> ("", "") + Just CustomPrelude{..} -> (cpPackage, cpModule) + +-- | Shows the Widget with the generated project structure tree. +renderWidgetTree :: SummonKit -> Text +renderWidgetTree = showTree False . createProjectTemplate . summonKitToSettings diff --git a/src/Summoner/Tui/Validation.hs b/src/Summoner/Tui/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Tui/Validation.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE Rank2Types #-} + +-- | This module contains function to validate Form fields. + +module Summoner.Tui.Validation + ( ctrlD + , summonFormValidation + , formErrorMessages + ) where + +import Brick.Forms (formState, invalidFields, setFieldValid, setFormFocus) +import Lens.Micro (Lens', (.~), (^.)) + +import Summoner.Tui.Form (KitForm, SummonForm (..), getCurrentFocus, mkForm) +import Summoner.Tui.Kit + +import qualified Data.Text as T + + +-- | Clears the 'Text' fields by @Ctrl + d@ key combination. +ctrlD :: KitForm e -> KitForm e +ctrlD = + clearField "" UserFullName (user . fullName) + . clearField "" UserEmail (user . email) + . clearField "" ProjectName (project . repo) + . clearField "" ProjectDesc (project . desc) + . clearField "" ProjectCat (project . category) + . clearField "" CustomPreludeName (projectMeta . preludeName) + . clearField "" CustomPreludeModule (projectMeta . preludeModule) + . clearField [] Ghcs (projectMeta . ghcs) + . clearField "" UserOwner (user . owner) + where + clearField :: a -> SummonForm -> Lens' SummonKit a -> KitForm e -> KitForm e + clearField nil formField fieldLens f = + if getCurrentFocus f == Just formField + then setFormFocus formField $ mkForm $ formState f & fieldLens .~ nil + else f + +-- | Validates the main @new@ command form. +summonFormValidation :: forall e . [FilePath] -> KitForm e -> KitForm e +summonFormValidation dirs kitForm = foldr setValidation kitForm universe + where + kit :: SummonKit + kit = formState kitForm + + wrongFields :: [SummonForm] + wrongFields = case validateKit dirs kit of + Success _ -> [] + Failure errors -> concatMap (toList . errorToInvalidFields) errors + + setValidation :: SummonForm -> KitForm e -> KitForm e + setValidation field = setFieldValid (field `notElem` wrongFields) field + +-- | This data type represents all possible errors that can happen during +-- validation of form input fields. +data FormError + -- | List of empty fields that shouldn't be empty. + = EmptyFields (NonEmpty SummonForm) + -- | List of fields that should be exactly one word. + | OneWord (NonEmpty SummonForm) + -- | Project with such name already exist. + | ProjectExist + -- | At least one build tool should be chosen. + | CabalOrStack + -- | At least library or executable should be selected. + | LibOrExe + +-- | Show 'FormError' to display later in TUI. +showFormError :: FormError -> String +showFormError = \case + ProjectExist -> "Directory with such name already exists" + CabalOrStack -> "Choose at least one: Cabal or Stack" + LibOrExe -> "Choose at least one: Library or Executable" + EmptyFields fields -> "These fields must not be empty: " ++ joinFields fields + OneWord fields -> "These fields should contain exactly one word: " ++ joinFields fields + where + joinFields :: NonEmpty SummonForm -> String + joinFields = intercalate ", " . mapMaybe showField . toList + + showField :: SummonForm -> Maybe String + showField = \case + UserOwner -> Just "Owner" + UserFullName -> Just "Full name" + UserEmail -> Just "Email" + ProjectName -> Just "Name" + ProjectDesc -> Just "Description" + ProjectCat -> Just "Category" + CustomPreludeName -> Just "Prelude name" + CustomPreludeModule -> Just "Module" + _ -> Nothing + +-- | Returns list of all invalid fields according to the error. +errorToInvalidFields :: FormError -> NonEmpty SummonForm +errorToInvalidFields = \case + EmptyFields fields -> fields + OneWord fields -> fields + ProjectExist -> one ProjectName + CabalOrStack -> CabalField :| [StackField] + LibOrExe -> Lib :| [Exe] + +-- | Takes boolean value and error and returns error if predicate 'True'. +toError :: Bool -> e -> Validation (NonEmpty e) () +toError p e = if p then Failure (one e) else Success () + +-- | Validates 'SummonKit' and returns list of all possible errors or success. +validateKit :: [FilePath] -> SummonKit -> Validation (NonEmpty FormError) () +validateKit dirs kit = + validateEmpty + *> validateOneWord + *> validateProjectExist + *> validateBuildTools + *> validateLibOrExe + where + liftValidation + :: (e -> FormError) + -> Validation e () + -> Validation (NonEmpty FormError) () + liftValidation mkError = first (one . mkError) + + validateEmpty :: Validation (NonEmpty FormError) () + validateEmpty = liftValidation EmptyFields validateFields + where + validateFields :: Validation (NonEmpty SummonForm) () + validateFields = + checkField (user . owner) UserOwner + *> checkField (user . fullName) UserFullName + *> checkField (user . email) UserEmail + *> checkField (project . repo) ProjectName + *> checkField (project . desc) ProjectDesc + *> toError isEmptyPrelude CustomPreludeModule + + checkField :: Lens' SummonKit Text -> SummonForm -> Validation (NonEmpty SummonForm) () + checkField textL = toError $ isEmpty $ kit ^. textL + + isEmpty :: Text -> Bool + isEmpty t = T.strip t == "" + + isEmptyPrelude :: Bool + isEmptyPrelude = + not (isEmpty $ kit ^. projectMeta . preludeName) + && isEmpty (kit ^. projectMeta . preludeModule) + + validateOneWord :: Validation (NonEmpty FormError) () + validateOneWord = liftValidation OneWord validateFields + where + validateFields :: Validation (NonEmpty SummonForm) () + validateFields = + checkField (user . owner) UserOwner + *> checkField (user . email) UserEmail + *> checkField (project . repo) ProjectName + *> checkField (projectMeta . preludeName) CustomPreludeName + *> checkField (projectMeta . preludeModule) CustomPreludeModule + + checkField :: Lens' SummonKit Text -> SummonForm -> Validation (NonEmpty SummonForm) () + checkField textL = toError (length (words $ kit ^. textL) > 1) + + validateProjectExist :: Validation (NonEmpty FormError) () + validateProjectExist = toError + (toString (kit ^. project . repo) `elem` dirs) + ProjectExist + + validateBuildTools :: Validation (NonEmpty FormError) () + validateBuildTools = toError + (not $ kit ^. cabal || kit ^. stack) + CabalOrStack + + validateLibOrExe :: Validation (NonEmpty FormError) () + validateLibOrExe = toError + (not $ kit ^. projectMeta . lib || kit ^. projectMeta . exe) + LibOrExe + +-- | Returns list of error messages according to all invalid fields. +formErrorMessages :: [FilePath] -> KitForm e -> [String] +formErrorMessages dirs kitForm = validatedErrorMessages ++ ghcErrorMessage + where + validatedErrorMessages :: [String] + validatedErrorMessages = case validateKit dirs (formState kitForm) of + Success _ -> [] + Failure errors -> map showFormError $ toList errors + + -- Hack because input field for GHC versions uses custom @editField@ with its own validation + ghcErrorMessage :: [String] + ghcErrorMessage = + ["Some GHC versions failed to parse: use space-separated valid GHC versions" + | Ghcs `elem` invalidFields kitForm + ] diff --git a/src/Summoner/Tui/Widget.hs b/src/Summoner/Tui/Widget.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Tui/Widget.hs @@ -0,0 +1,86 @@ +{- | This module contains useful helpers to work with 'Widget's +-} + +module Summoner.Tui.Widget + ( label + , borderLabel + , borderName + , hArrange + , listInBorder + ) where + +import Brick.Types (Padding (Pad), Widget) +import Brick.Widgets.Border (borderWithLabel) +import Brick.Widgets.Center (center) +import Brick.Widgets.Core (hBox, hLimit, padLeftRight, padRight, str, txtWrap, vBox, vLimit, + withAttr, (<+>)) + + +-- | Adds label to the Form's field. +label :: String -> Widget n -> Widget n +label l = (<+>) (str l) + +{- | Like 'borderWithLabel' but receives 'String'. Also adds padding and fancy +unicode characters for border label. + +__Example:__ + +@ +โ”Œโ”€โ”€โ”€โ”€โ”€โ•ผ Some label โ•พโ”€โ”€โ”€โ” +โ”‚ โ”‚ +โ”‚ โ”‚ +โ”‚ โ”‚ +โ”‚ โ”‚ +โ”‚ โ”‚ +โ””โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”˜ +@ +-} +borderLabel :: String -> Widget n -> Widget n +borderLabel l = borderWithLabel (borderName l) + +-- | Border label pretty text 'Widget' +borderName :: String -> Widget n +borderName l = str "โ•ผ" <+> padLeftRight 1 (str l) <+> str "โ•พ" + +{- | Arranges 'Widget's horizontally. + +__Example:__ + +@ + [x] Cabal [ ] Stack +@ +-} +hArrange :: [Widget n] -> Widget n +hArrange = hBox . updateHead (padRight (Pad 2)) + where + updateHead :: (a -> a) -> [a] -> [a] + updateHead _ [] = [] + updateHead f (a : as) = f a : as + +{- | Shows list of elements inside 'borderWithLabel'. + +__Example:__ + +@ +โ”Œโ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€Some labelโ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ” +โ”‚ โ”‚ +โ”‚ > 8.2.2 โ”‚ +โ”‚ > 8.4.3 โ”‚ +โ”‚ > 8.4.4 โ”‚ +โ”‚ โ”‚ +โ””โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”€โ”˜ +@ +-} +listInBorder + :: String -- ^ Border label + -> Int -- ^ Horizontal limit + -> Int -- ^ Additional vertical limit + -> [Text] -- ^ List of text entries + -> Widget n +listInBorder name limitH extraLimitV list = center + $ hLimit limitH + $ vLimit (length list + 4 + extraLimitV) + $ borderLabel name + $ center + $ vBox + $ map (withAttr "blue-fg" . txtWrap . ("โžค " <>)) list diff --git a/summoner-tui.cabal b/summoner-tui.cabal new file mode 100644 --- /dev/null +++ b/summoner-tui.cabal @@ -0,0 +1,92 @@ +cabal-version: 2.0 +name: summoner-tui +version: 0.1.0 +synopsis: Tool for scaffolding fully configured batteries-included production-level Haskell projects using TUI. +description: Tool for scaffolding fully configured batteries-included production-level Haskell projects using TUI. + 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 +license-file: LICENSE +author: Kowainik +maintainer: xrom.xkov@gmail.com +copyright: 2018-2019 Kowainik +category: TUI, TUI Tool, Development +build-type: Simple +stability: experimental +extra-doc-files: README.md + , CHANGELOG.md +tested-with: GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.4 + +source-repository head + type: git + location: git@github.com:kowainik/summoner.git + +library + if os(windows) + buildable: False + hs-source-dirs: src + exposed-modules: Summoner.Tui + Summoner.Tui.Field + Summoner.Tui.Form + Summoner.Tui.GroupBorder + Summoner.Tui.Kit + Summoner.Tui.Validation + Summoner.Tui.Widget + + autogen-modules: Paths_summoner_tui + other-modules: Paths_summoner_tui + Prelude + + build-depends: base-noprelude >= 4.10 && < 4.13 + , brick ^>= 0.47 + , directory ^>= 1.3.0.2 + , filepath ^>= 1.4.1.2 + , microlens ^>= 0.4 + , microlens-th ^>= 0.4 + , relude ^>= 0.5.0 + , summoner ^>= 1.3.0 + , text ^>= 1.2.3.0 + , vty ^>= 5.25 + + ghc-options: -Wall + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths + + default-extensions: DeriveGeneric + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + OverloadedStrings + RecordWildCards + ScopedTypeVariables + TypeApplications + + default-language: Haskell2010 + +executable summon-tui + if os(windows) + buildable: False + hs-source-dirs: app + main-is: Tui.hs + build-depends: base >= 4.10 && < 4.13 + , summoner-tui + + ghc-options: -Wall + -threaded + -rtsopts + -with-rtsopts=-N + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths + + default-language: Haskell2010