diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,53 @@ +# Summoner + +1.0.0 +===== + +* __Important:__ Rename `hs-init` to `summoner`. Transform the script into the package. +* [#54](https://github.com/kowainik/summoner/issues/54): + Rename `on` and `off` commands to `with` and `without`. +* [#48](https://github.com/kowainik/summoner/issues/48): + - Add ability to write configurations file. Remove `Targets` data type. + Use `Config` instead for default, file and CLI configurations. +* [#60](https://github.com/kowainik/summoner/issues/60): + Use custom prelude `universum`. +* [#39](https://github.com/kowainik/summoner/issues/39): + Add option to use custom prelude in CLI and in `.toml` configuration. +* [#38](https://github.com/kowainik/summoner/issues/38): + Add option to add default extensions to `.toml` config. +* [#62](https://github.com/kowainik/summoner/issues/62): + Make some parts of output not only colorful, but also bold. This makes output prettier. +* [#67](https://github.com/kowainik/summoner/issues/67): + Add `Aswer` data type to handle yes-no CLI questions. +* [#61](https://github.com/kowainik/summoner/issues/61): + Add CLI `--version` option. +* [#73](https://github.com/kowainik/summoner/issues/73): + Make custom prelude be table in toml. +* [#74](https://github.com/kowainik/summoner/issues/74): + Print hierarchy tree for the created project. + +# hs-init + +0.0.4 +===== +* Now works on windows systems as well +* Add powershell install script for Windows + + +0.0.3 +===== + +* [#45](https://github.com/vrom911/hs-init/issues/45): + Support AppVeyor CI for created projects. + +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 +===== + +* [#36](https://github.com/vrom911/hs-init/issues/36): + Add option for creating private repositories — `-p | --private`. 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,231 @@ +# :crystal_ball: Summoner + +[![Build status](https://secure.travis-ci.org/kowainik/summoner.svg)](http://travis-ci.org/kowainik/summoner) +[![Windows build status](https://ci.appveyor.com/api/projects/status/github/kowainik/summoner?branch=master&svg=true)](https://ci.appveyor.com/project/kowainik/summoner) +[![MPL-2.0 license](https://img.shields.io/badge/license-MPL--2.0-blue.svg)](https://github.com/kowainik/summoner/blob/master/LICENSE) +[![Hackage](https://img.shields.io/hackage/v/summoner.svg)](https://hackage.haskell.org/package/summoner) + +This is tool for creating completely configured production Haskell projects. +Consider that it's using [`Stack`](http://haskellstack.org) for +creating and setting up projects. + +## Demo + +[![asciicast](https://asciinema.org/a/Wf8ZOMAZSUFyAJob70pwM6rZ1.png](https://asciinema.org/a/Wf8ZOMAZSUFyAJob70pwM6rZ1) + +## Getting started + +### Prerequisites + +To start using it make sure you have next tools installed on your machine: +* [`Stack`](http://haskellstack.org) +* [`git`](https://git-scm.com) +* [`hub`](https://github.com/github/hub) + +### Installation + +Installation process can be done with one simple command: + + $ stack install summoner + +You can turn on the bash auto-completion by running the following command: + +``` +$ source <(summon --bash-completion-script `which summon`) +``` + +After that you can call `summon` with required command line options, follow +the instructions that will appear, and a new project would be created in a subfolder +as well as a repository under your github account (if requested). + +### Usage + +There are several options how to set particular configurations: + +1. Default configuration file (`~/.summoner.toml`). +2. Explicitly specified configuration file by `--file FILENAME` option (used instead of 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). + +So the configuration uses [`Partial Options Monoid Pattern`](https://medium.com/@jonathangfischoff/the-partial-options-monoid-pattern-31914a71fc67). + +If none of the mentioned above cases used then the configuration will be built interactively. + +#### Configurations + +##### `.toml` files: + +Here is the list of the options that could be configured for your needs: + +###### Global keys + +* `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`. +* `bscript` – `true` if you want to include [build script](#build-script) by default, + `false` if you don't. 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 dummy `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`. + +###### Custom prelude options + +Should be specified inside `[prelude]` table. + +* `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). + +###### Examples + +See example of [configuration for projects of `Kowainik` organization](https://github.com/kowainik/org/blob/master/summoner.toml). + +By default the `summoner` will look for the configuration file (`.summoner.toml`) in home directory. + +The other way to specify some particular `.toml` file is `summon PROJECTNAME --file FILEPATH` command. + +##### CLI + +See the basic usage syntax below (you can check it out with `summon --help` command): + +``` +summon PROJECT_NAME [with [OPTIONS]] [without [OPTIONS]] + [-f|--file FILENAME] [--prelude-package PACKAGE_NAME] + [--prelude-module MODULE_NAME] + +Available global options: + -h, --help Show this help text + -v, --version Show summoner's version + -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 + -s, --script Build script + -l, --library Library target + -e, --exec Executable target + -t, --test Tests + -b, --benchmark Benchmarks + +``` + +The options to be enabled/disabled can be specified while running the command. +If any of applicable command options wasn't tagged as enabled/disabled then +the question will be asked during the work of the script. + +For example, + +``` + summon newProject with -letgcspw without -b --prelude-package universum --prelude-module Universum +``` +will create fully functional project which uses custom prelude `universum`, contains +library, executable file, tests, [build script](#build-script) +and create private repository on [github](https://github.com) +integrated with `Travis-CI`, `AppVeyor-CI`, but benchmarks won't be attached to this one. + +But when calling this command + +``` + summon newProject +``` + +the tool will ask about every particular option, rather you'd like to have it +or not in your project. + +### Note + +This tool was tested with next settings: + + stack version 1.6.1 + git version 2.11.0 + hub version 2.2.9 + +## Features + +If you're running the `summoner` with all options enabled a project with the following +hierarchy will be created: + +``` +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 +``` +and also repository with one commit at master will be added with enabled `Travis-CI` for that. + +### Build script + +The `b` script builds the project in a way that is convenient for developers. +It passes the right flags into right places, builds the project with --fast, +tidies up and highlights error messages in GHC output. + +#### Usage + +``` + ./b build whole project with all targets + ./b -c do stack clean + ./b -t build and run tests + ./b -b build and run benchmarks + ./b --nix use nix to build package +``` + +## Change log + +[List of changes](https://github.com/kowainik/summoner/blob/master/CHANGELOG.md). + +## Acknowledgments + +This project was inspired by [Aelve/new-hs](https://github.com/aelve/new-hs#readme), +which is the tool with the same goal but the difference is that it's using +[`cabal`](https://www.haskell.org/cabal/) for creating projects. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import System.IO (hSetEncoding, utf8) + +import Summoner (summon) + +main :: IO () +main = hSetEncoding stdout utf8 >> summon diff --git a/src/Prelude.hs b/src/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Prelude.hs @@ -0,0 +1,7 @@ +-- | Uses [universum](http://hackage.haskell.org/package/universum) as default prelude. + +module Prelude + ( module Universum + ) where + +import Universum hiding (Key) diff --git a/src/Summoner.hs b/src/Summoner.hs new file mode 100644 --- /dev/null +++ b/src/Summoner.hs @@ -0,0 +1,27 @@ +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 + ) 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 diff --git a/src/Summoner/Ansi.hs b/src/Summoner/Ansi.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Ansi.hs @@ -0,0 +1,82 @@ +-- | This module contains functions for colorful printing into terminal. + +module Summoner.Ansi + ( Color (..) + , putStrFlush + , beautyPrint + , bold + , boldText + , boldDefault + , italic + , reset + , prompt + , setColor + , successMessage + , warningMessage + , errorMessage + , infoMessage + , skipMessage + ) where + +import System.Console.ANSI (Color (..), ColorIntensity (Vivid), ConsoleIntensity (BoldIntensity), + ConsoleLayer (Foreground), SGR (..), setSGR) +import System.IO (hFlush) + +---------------------------------------------------------------------------- +-- Ansi-terminal +---------------------------------------------------------------------------- + +-- Explicit flush ensures prompt messages are in the correct order on all systems. +putStrFlush :: Text -> IO () +putStrFlush msg = do + putText msg + hFlush stdout + +setColor :: Color -> IO () +setColor color = setSGR [SetColor Foreground Vivid color] + +-- | Starts bold printing. +bold :: IO () +bold = setSGR [SetConsoleIntensity BoldIntensity] + +italic :: IO () +italic = setSGR [SetItalicized True] + +-- | Resets all previous settings. +reset :: IO () +reset = do + setSGR [Reset] + hFlush stdout + +-- | Takes list of formatting options, prints text using this format options. +beautyPrint :: [IO ()] -> Text -> IO () +beautyPrint formats msg = do + sequence_ formats + putText msg + reset + +prompt :: IO Text +prompt = do + setColor Blue + putStrFlush " -> " + reset + getLine + +boldText :: Text -> IO () +boldText message = bold >> putStrFlush message >> reset + +boldDefault :: Text -> IO () +boldDefault message = boldText (" [" <> message <> "]") + +colorMessage :: Color -> Text -> IO () +colorMessage color message = do + setColor color + putTextLn $ " " <> message + reset + +errorMessage, warningMessage, successMessage, infoMessage, skipMessage :: Text -> IO () +errorMessage = colorMessage Red +warningMessage = colorMessage Yellow +successMessage = colorMessage Green +infoMessage = colorMessage Blue +skipMessage = colorMessage Cyan diff --git a/src/Summoner/CLI.hs b/src/Summoner/CLI.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/CLI.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} + +-- | This module contains functions and data types to parse CLI inputs. + +module Summoner.CLI + ( summon + ) where + +import Data.Version (showVersion) +import NeatInterpolation (text) +import Options.Applicative (Parser, ParserInfo, command, execParser, flag, fullDesc, help, helper, + info, infoFooter, infoHeader, infoOption, long, metavar, optional, + progDesc, short, strArgument, strOption, subparser) +import Options.Applicative.Help.Chunk (stringChunk) +import System.Directory (doesFileExist) + +import Paths_summoner (version) +import Summoner.Ansi (Color (Green), beautyPrint, bold, errorMessage, infoMessage, setColor, + warningMessage) +import Summoner.Config (ConfigP (..), PartialConfig, defaultConfig, finalise, loadFileConfig) +import Summoner.Default (defaultConfigFile, endLine) +import Summoner.Project (generateProject) +import Summoner.ProjectData (CustomPrelude (..), Decision (..)) +import Summoner.Validation (Validation (..)) + +--------------------------------------------------------------------------- +-- CLI +---------------------------------------------------------------------------- + +summon :: IO () +summon = execParser prsr >>= runWithOptions + +-- | Run 'hs-init' with cli options +runWithOptions :: InitOpts -> IO () +runWithOptions (InitOpts projectName maybeFile cliConfig) = do + -- read config from file + fileConfig <- readFileConfig maybeFile + + -- union all possible configs + let unionConfig = defaultConfig <> fileConfig <> cliConfig + + -- 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" + +readFileConfig :: Maybe FilePath -> IO PartialConfig +readFileConfig maybeFile = do + (isDefault, file) <- case maybeFile of + Nothing -> (True,) <$> defaultConfigFile + Just x -> pure (False, x) + + isFile <- doesFileExist file + + if isFile then do + infoMessage $ "Configurations from " <> toText file <> " will be used." + loadFileConfig file + else if isDefault then do + fp <- toText <$> defaultConfigFile + warningMessage $ "Default config " <> fp <> " file is missing." + pure mempty + else do + errorMessage $ "Specified configuration file " <> toText file <> " is not found." + exitFailure + +-- | Initial parsed options from cli +data InitOpts = InitOpts Text (Maybe FilePath) PartialConfig + -- ^ Includes the project name, config from the CLI and possible file where custom congifs are. + +targetsP :: Decision -> Parser PartialConfig +targetsP d = do + cGitHub <- githubP d + cTravis <- travisP d + cAppVey <- appVeyorP d + cPrivate <- privateP d + cScript <- scriptP d + cLib <- libraryP d + cExe <- execP d + cTest <- testP d + cBench <- benchmarkP d + pure mempty + { cGitHub = cGitHub + , cTravis = cTravis + , cAppVey = cAppVey + , cPrivate= cPrivate + , cScript = cScript + , cLib = cLib + , cExe = cExe + , cTest = cTest + , cBench = cBench + } + +githubP :: Decision -> Parser Decision +githubP d = flag Idk d + $ long "github" + <> short 'g' + <> help "GitHub integration" + +travisP :: Decision -> Parser Decision +travisP d = flag Idk d + $ long "travis" + <> short 'c' + <> help "Travis CI integration" + +appVeyorP :: Decision -> Parser Decision +appVeyorP d = flag Idk d + $ long "app-veyor" + <> short 'w' + <> help "AppVeyor CI integration" + +privateP :: Decision -> Parser Decision +privateP d = flag Idk d + $ long "private" + <> short 'p' + <> help "Private repository" + +scriptP :: Decision -> Parser Decision +scriptP d = flag Idk d + $ long "script" + <> short 's' + <> help "Build script for convenience" + +libraryP :: Decision -> Parser Decision +libraryP d = flag Idk d + $ long "library" + <> short 'l' + <> help "Library folder" + +execP :: Decision -> Parser Decision +execP d = flag Idk d + $ long "exec" + <> short 'e' + <> help "Executable target" + +testP :: Decision -> Parser Decision +testP d = flag Idk d + $ long "test" + <> short 't' + <> help "Test target" + +benchmarkP :: Decision -> Parser Decision +benchmarkP d = flag Idk d + $ long "benchmark" + <> short 'b' + <> help "Benchmarks" + +withP :: Parser PartialConfig +withP = subparser $ mconcat + [ metavar "with [OPTIONS]" + , command "with" $ info (helper <*> targetsP Yes) (progDesc "Specify options to enable") + ] + +withoutP :: Parser PartialConfig +withoutP = subparser $ mconcat + [ metavar "without [OPTIONS]" + , command "without" $ info (helper <*> targetsP Nop) (progDesc "Specify options to disable") + ] + +fileP :: Parser FilePath +fileP = strOption + $ long "file" + <> short 'f' + <> metavar "FILENAME" + <> help "Path to the toml file with configurations. If not specified '~/.summoner.toml' will be used if present" + +preludePackP :: Parser Text +preludePackP = strOption + $ long "prelude-package" + <> metavar "PACKAGE_NAME" + <> help "Name for the package of the custom prelude to use in the project" + +preludeModP :: Parser Text +preludeModP = strOption + $ long "prelude-module" + <> metavar "MODULE_NAME" + <> help "Name for the module of the custom prelude to use in the project" + +optsP :: Parser InitOpts +optsP = do + projectName <- strArgument (metavar "PROJECT_NAME") + with <- optional withP + without <- optional withoutP + file <- optional fileP + preludePack <- optional preludePackP + preludeMod <- optional preludeModP + + pure $ InitOpts projectName file + $ (maybeToMonoid $ with <> without) + { cPrelude = Last $ Prelude <$> preludePack <*> preludeMod + } + +versionP :: Parser (a -> a) +versionP = infoOption summonerVersion + $ long "version" + <> short 'v' + <> help "Show summoner's version" + where + summonerVersion :: String + summonerVersion = showVersion version + + +prsr :: ParserInfo InitOpts +prsr = modifyHeader + $ modifyFooter + $ info ( helper <*> versionP <*> optsP ) + $ fullDesc + <> progDesc "Create your own haskell project" + +-- to put custom header which doesn't cut all spaces +modifyHeader :: ParserInfo InitOpts -> ParserInfo InitOpts +modifyHeader initOpts = initOpts {infoHeader = stringChunk $ toString artHeader} + +-- to put custom footer which doesn't cut all spaces +modifyFooter :: ParserInfo InitOpts -> ParserInfo InitOpts +modifyFooter initOpts = initOpts {infoFooter = stringChunk $ toString artFooter} + +artHeader :: Text +artHeader = [text| +$endLine + ___ + ╱ . ╲ + │╲_/│ │ + │ │ ╱│ + ___________________________________________________-' │ + ╱ │ +╱ .-. │ +│ ╱ ╲ │ +│ │\_. │ Summoner — tool for creating Haskell projects │ +│\│ │ ╱│ │ +│ `-_-' │ ╱ +│ │_____________________________________________╱ +│ │ + ╲ ╱ + `-_-' +|] + +artFooter :: Text +artFooter = [text| +$endLine + , * + + + o * ┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━┓ + * @ ╭─╮ . ________┃ ┃_______ + ╱| . │λ│ @ ' ╲ ┃ λ Haskell's summon scroll λ ┃ ╱ + _╱ ╰─ ╰╥╯ O ╲ ┃ ┃ ╱ + .─╲"╱. * ║ + ╱ ┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━┛ ╲ + ╱ ( ) ╲_ ║ ╱__________) (_________╲ + ╲ ╲(')╲__(╱ + ╱╱`)╱ `╮ ║ + `╲. ╱╱ ( │ ║ + ╲.╲╱ │ ║ + `╰══════════╯ +$endLine +|] diff --git a/src/Summoner/Config.hs b/src/Summoner/Config.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Config.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Summoner configurations. + +module Summoner.Config + ( ConfigP (..) + + , PartialConfig + , Config + , defaultConfig + , finalise + + , loadFileConfig + ) where + +import Control.Exception (throwIO) +import Data.List (lookup) +import Data.Monoid (Last (..)) +import Generics.Deriving.Monoid (GMonoid, gmemptydefault) +import Generics.Deriving.Semigroup (GSemigroup, gsappenddefault) +import Toml (ValueType (TString), matchText) +import Toml.Bi (BiToml, dimap, (.=)) +import Toml.Bi.Combinators (Valuer (..)) +import Toml.PrefixTree (Key) + +import Summoner.License (License (..)) +import Summoner.ProjectData (CustomPrelude (..), Decision (..), GhcVer (..), parseGhcVer, + showGhcVer) +import Summoner.Validation (Validation (..)) + +import qualified Text.Show as Show +import qualified Toml + +data Phase = Partial | Final + +-- | Potentially incomplete configuration. +data ConfigP (p :: Phase) = Config + { cOwner :: p :- Text + , cFullName :: p :- Text + , cEmail :: p :- Text + , cLicense :: p :- License + , cGhcVer :: p :- [GhcVer] + , cGitHub :: Decision + , cTravis :: Decision + , cAppVey :: Decision + , cPrivate :: Decision + , cScript :: Decision + , cLib :: Decision + , cExe :: Decision + , cTest :: Decision + , cBench :: Decision + , cPrelude :: Last CustomPrelude + , cExtensions :: [Text] + } deriving (Generic) + +deriving instance (GSemigroup (p :- Text), GSemigroup (p :- License), GSemigroup (p :- [GhcVer])) => GSemigroup (ConfigP p) +deriving instance (GMonoid (p :- Text), GMonoid (p :- License), GMonoid (p :- [GhcVer])) => GMonoid (ConfigP p) + +infixl 3 :- +type family phase :- field where + 'Partial :- field = Last field + 'Final :- field = field + +-- | Incomplete configurations. +type PartialConfig = ConfigP 'Partial + +-- | Complete configurations. +type Config = ConfigP 'Final + +instance Semigroup PartialConfig where + (<>) = gsappenddefault + +instance Monoid PartialConfig where + mempty = gmemptydefault + mappend = (<>) + +-- | Default 'Config' configurations. +defaultConfig :: PartialConfig +defaultConfig = Config + { cOwner = Last (Just "kowainik") + , cFullName = Last (Just "Kowainik") + , cEmail = Last (Just "xrom.xkov@gmail.com") + , cLicense = Last (Just $ License "MIT") + , cGhcVer = Last (Just []) + , cGitHub = Idk + , cTravis = Idk + , cAppVey = Idk + , cPrivate = Idk + , cScript = Idk + , cLib = Idk + , cExe = Idk + , cTest = Idk + , cBench = Idk + , cPrelude = Last Nothing + , cExtensions = [] + } + +-- | Identifies how to read 'Config' data from the @.toml@ file. +configT :: BiToml PartialConfig +configT = Config + <$> lastP Toml.str "owner" .= cOwner + <*> lastP Toml.str "fullName" .= cFullName + <*> lastP Toml.str "email" .= cEmail + <*> lastP license "license" .= cLicense + <*> lastP ghcVerArr "ghcVersions" .= cGhcVer + <*> decision "github" .= cGitHub + <*> decision "travis" .= cTravis + <*> decision "appveyor" .= cAppVey + <*> decision "private" .= cPrivate + <*> decision "bscript" .= cScript + <*> decision "lib" .= cLib + <*> decision "exe" .= cExe + <*> decision "test" .= cTest + <*> decision "bench" .= cBench + <*> lastP (Toml.table preludeT) "prelude" .= cPrelude + <*> extensions "extensions" .= cExtensions + where + lastP :: (Key -> BiToml a) -> Key -> BiToml (Last a) + lastP f = dimap getLast Last . Toml.maybeP f + + ghcVerV :: Valuer 'TString GhcVer + ghcVerV = Valuer (matchText >=> parseGhcVer) (Toml.String . showGhcVer) + + ghcVerArr :: Key -> BiToml [GhcVer] + ghcVerArr = Toml.arrayOf ghcVerV + + license :: Key -> BiToml License + license = dimap unLicense License . Toml.str + + extensions :: Key -> BiToml [Text] + extensions = dimap Just maybeToMonoid . Toml.maybeP (Toml.arrayOf Toml.strV) + + decision :: Key -> BiToml Decision + decision = dimap fromDecision toDecision . Toml.maybeP Toml.bool + + decisionMaybe :: [(Decision, Maybe Bool)] + decisionMaybe = [ (Idk, Nothing) + , (Yes, Just True) + , (Nop, Just False) + ] + + fromDecision :: Decision -> Maybe Bool + fromDecision d = join $ lookup d decisionMaybe + + toDecision :: Maybe Bool -> Decision + toDecision m = fromMaybe (error "Impossible") $ lookup m $ map swap decisionMaybe + + preludeT :: BiToml CustomPrelude + preludeT = Prelude + <$> Toml.str "package" .= cpPackage + <*> Toml.str "module" .= cpModule + +-- | Make sure that all the required configurations options were specified. +finalise :: PartialConfig -> Validation [Text] Config +finalise Config{..} = Config + <$> fin "owner" cOwner + <*> fin "fullName" cFullName + <*> fin "email" cEmail + <*> fin "license" cLicense + <*> fin "ghcersions" cGhcVer + <*> pure cGitHub + <*> pure cTravis + <*> pure cAppVey + <*> pure cPrivate + <*> pure cScript + <*> pure cLib + <*> pure cExe + <*> pure cTest + <*> pure cBench + <*> pure cPrelude + <*> pure cExtensions + where + fin name = maybe (Failure ["Missing field: " <> name]) Success . getLast + +-- | Read configuration from the given file and return it in data type. +loadFileConfig :: MonadIO m => FilePath -> m PartialConfig +loadFileConfig filePath = (Toml.decode configT <$> readFile filePath) >>= liftIO . errorWhenLeft + where + errorWhenLeft :: Either Toml.DecodeException PartialConfig -> IO PartialConfig + errorWhenLeft (Left e) = throwIO $ LoadTomlException filePath $ Toml.prettyException e + errorWhenLeft (Right pc) = pure pc + +data LoadTomlException = LoadTomlException FilePath Text + +instance Show.Show LoadTomlException where + show (LoadTomlException filePath msg) = "Couldnt parse file " ++ filePath ++ ": " ++ show msg + +instance Exception LoadTomlException diff --git a/src/Summoner/Default.hs b/src/Summoner/Default.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Default.hs @@ -0,0 +1,37 @@ +-- | This module contains some default values to use. + +module Summoner.Default + ( defaultGHC + , defaultTomlFile + , defaultConfigFile + , currentYear + , endLine + ) where + +import Data.Time (getCurrentTime, toGregorian, utctDay) +import System.Directory (getHomeDirectory) +import System.FilePath (()) + +import Summoner.ProjectData (GhcVer (Ghc822)) + +---------------------------------------------------------------------------- +-- Default Settings +---------------------------------------------------------------------------- + +defaultGHC :: GhcVer +defaultGHC = Ghc822 + +defaultTomlFile :: String +defaultTomlFile = ".summoner.toml" + +defaultConfigFile :: IO FilePath +defaultConfigFile = ( defaultTomlFile) <$> getHomeDirectory + +currentYear :: IO Text +currentYear = do + now <- getCurrentTime + let (year, _, _) = toGregorian $ utctDay now + pure $ show year + +endLine :: Text +endLine = "\n" diff --git a/src/Summoner/License.hs b/src/Summoner/License.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/License.hs @@ -0,0 +1,49 @@ +module Summoner.License + ( License (..) + , customizeLicense + , licenseNames + , githubLicenseQueryNames + ) where + +import Data.Aeson (FromJSON (..), withObject, (.:)) + +import qualified Data.Text as T + +---------------------------------------------------------------------------- +-- License +---------------------------------------------------------------------------- + +licenseNames :: [License] +licenseNames = map fst githubLicenseQueryNames + +githubLicenseQueryNames :: [(License, Text)] +githubLicenseQueryNames = + [ ("MIT", "mit") + , ("BSD2", "bsd-2-clause") + , ("BSD3", "bsd-3-clause") + , ("GPL-2", "gpl-2.0") + , ("GPL-3", "gpl-3.0") + , ("LGPL-2.1", "lgpl-2.1") + , ("LGPL-3", "lgpl-3.0") + , ("AGPL-3", "agpl-3.0") + , ("Apache-2.0", "apache-2.0") + , ("MPL-2.0", "mpl-2.0") + ] + +newtype License = License { unLicense :: Text } + deriving (IsString, Eq, Ord, Show) + +instance FromJSON License where + parseJSON = withObject "License" $ \o -> License <$> o .: "body" + +customizeLicense :: Text -> Text -> Text -> Text -> Text +customizeLicense l t nm year + | l `elem` words "MIT BSD2 BSD3" = updateLicenseText + | otherwise = t + where + updateLicenseText = + let (beforeY, withY) = T.span (/= '[') t + afterY = T.tail $ T.dropWhile (/= ']') withY + (beforeN, withN) = T.span (/= '[') afterY + afterN = T.tail $ T.dropWhile (/= ']') withN + in beforeY <> year <> beforeN <> nm <> afterN diff --git a/src/Summoner/Process.hs b/src/Summoner/Process.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Process.hs @@ -0,0 +1,32 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module contains various function to work with commands. +module Summoner.Process + ( deleteFile + ) where + +import Control.Exception (displayException) +import System.Directory (removeFile, setCurrentDirectory) +import System.Process (callProcess) + +import Summoner.Ansi (errorMessage) + +---------------------------------------------------------------------------- +-- Commands +---------------------------------------------------------------------------- + +-- This is needed to be able to call commands by writing strings. +instance (a ~ Text, b ~ ()) => IsString ([a] -> IO b) where + fromString "cd" [arg] = setCurrentDirectory $ toString arg + fromString cmd args = callProcess cmd (map toString args) + +-- 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 + printError :: SomeException -> IO () + printError e = errorMessage $ "Could not delete file '" + <> toText file <> "'. " <> toText (displayException e) diff --git a/src/Summoner/Project.hs b/src/Summoner/Project.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Project.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | This module introduces functional for project creation. + +module Summoner.Project + ( generateProject + ) where + +import Data.Aeson (decodeStrict) +import Data.ByteString.Char8 (pack) +import NeatInterpolation (text) +import System.Info (os) +import System.Process (readProcess) + +import Summoner.Ansi (infoMessage, successMessage) +import Summoner.Config (Config, ConfigP (..)) +import Summoner.Default (currentYear, defaultGHC) +import Summoner.License (License (..), customizeLicense, githubLicenseQueryNames, licenseNames) +import Summoner.Process () +import Summoner.ProjectData (CustomPrelude (..), Decision (..), ProjectData (..), parseGhcVer, + showGhcVer, supportedGhcVers) +import Summoner.Question (checkUniqueName, choose, chooseYesNo, chooseYesNoBool, falseMessage, + query, queryDef, queryManyRepeatOnFail, trueMessage) +import Summoner.Template (createStackTemplate) +import Summoner.Text (intercalateMap, packageToModule) +import Summoner.Tree (showTree, traverseTree) + +import qualified Universum.Unsafe as Unsafe + +decisionToBool :: Decision -> Text -> IO Bool +decisionToBool decision target = case decision of + Yes -> trueMessage target + Nop -> falseMessage target + Idk -> chooseYesNoBool target + +-- | Generate the project. +generateProject :: Text -> Config -> IO () +generateProject projectName Config{..} = do + repo <- checkUniqueName projectName + owner <- queryDef "Repository owner: " cOwner + description <- query "Short project description: " + nm <- queryDef "Author: " cFullName + email <- queryDef "Maintainer e-mail: " cEmail + putText categoryText + category <- query "Category: " + license <- choose "License: " $ map unLicense $ ordNub (cLicense : licenseNames) + + -- License creation + let licenseGithub = snd + $ Unsafe.head + $ dropWhile ((/= license) . unLicense . fst) githubLicenseQueryNames + let licenseLink = "https://api.github.com/licenses/" <> licenseGithub + licenseJson <- + readProcess "curl" + [ toString licenseLink + , "-H" + , "Accept: application/vnd.github.drax-preview+json" + ] + "" + year <- currentYear + let licenseText = case (decodeStrict $ pack licenseJson) :: Maybe License of + Just t -> customizeLicense license (unLicense t) nm year + Nothing -> error "Broken predefined license list" + + -- Library/Executable/Tests/Benchmarks flags + github <- decisionToBool cGitHub "GitHub integration" + travis <- ifGithub github "Travis CI integration" cTravis + appVey <- ifGithub github "AppVeyor CI integration" cAppVey + privat <- ifGithub github "private repository" cPrivate + script <- decisionToBool cScript "build script" + 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 + Nothing -> "base" + Just _ -> "base-noprelude" + + let extensions = cExtensions + + putTextLn $ "The project will be created with the latest resolver for default GHC-" <> showGhcVer defaultGHC + testedVersions <- (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 supportedGhcVers + queryManyRepeatOnFail parseGhcVer + vers -> do + putTextLn $ "Also these GHC versions will be added: " <> intercalateMap " " showGhcVer vers + pure vers + + -- Create project data from all variables in scope + let projectData = ProjectData{..} + + -- create stack project + createProjectDirectory projectData + -- make b executable + when script doScriptCommand + -- create github repository and commit + when github $ doGithubCommands projectData privat + + where + ifGithub :: Bool -> Text -> Decision -> IO Bool + ifGithub github target decision = if github + then decisionToBool decision target + else falseMessage target + + createProjectDirectory :: ProjectData -> IO () + createProjectDirectory projectData@ProjectData{..} = do + let tree = createStackTemplate projectData + traverseTree tree + successMessage "\nThe project with the following structure has been created:" + putTextLn $ showTree tree + "cd" [repo] + + doScriptCommand :: IO () + doScriptCommand = when (os /= "mingw32") ("chmod" ["+x", "b"]) + + 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| + List of categories to choose from: + + * Control * Concurrency + * Codec * Graphics + * Data * Sound + * Math * System + * Parsing * Network + * Text + + * Application * Development + * Compilers/Interpreters * Testing + * Web + * Game + * Utility + + |] + + getPrelude :: IO (Maybe CustomPrelude) + getPrelude = case cPrelude of + Last Nothing -> do + let yesDo, noDo :: IO (Maybe CustomPrelude) + yesDo = do + p <- query "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 + noDo = pure Nothing + chooseYesNo "custom prelude" yesDo noDo + Last prelude@(Just (Prelude p _)) -> do + prelude <$ successMessage ("Custom prelude " <> p <> " will be used in the project") diff --git a/src/Summoner/ProjectData.hs b/src/Summoner/ProjectData.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/ProjectData.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE ViewPatterns #-} + +module Summoner.ProjectData + ( ProjectData (..) + , GhcVer (..) + , supportedGhcVers + , parseGhcVer + , showGhcVer + , latestLts + , baseNopreludeVer + + , Decision (..) + , CustomPrelude (..) + + , Answer (..) + , yesOrNo + ) where + +import Generics.Deriving.Monoid (GMonoid (..)) +import Generics.Deriving.Semigroup (GSemigroup (..)) + +import qualified Data.Text as T + +-- | 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 + , license :: Text -- ^ type of license + , licenseText :: Text -- ^ license text + , github :: Bool -- ^ github repository + , travis :: Bool -- ^ Travis CI integration + , appVey :: Bool -- ^ AppVeyor CI integration + , script :: Bool -- ^ build script + , 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 + } deriving (Show) + +-- | Used for detecting the user decision during CLI input. +data Decision = Yes | Nop | Idk + deriving (Show, Eq, Enum, Bounded, Generic) + +instance Semigroup Decision where + (<>) :: Decision -> Decision -> Decision + Idk <> x = x + x <> Idk = x + _ <> x = x + +instance Monoid Decision where + mempty = Idk + mappend = (<>) + +instance GSemigroup Decision where + gsappend = (<>) + +instance GMonoid Decision where + gmempty = mempty + gmappend = (<>) + +-- | Represents some selected set of GHC versions. +data GhcVer = Ghc7103 + | Ghc801 + | Ghc802 + | Ghc822 + deriving (Eq, Ord, Show, Enum, Bounded) + +-- | Supported by @summoner@ GHC versions for project templates. +supportedGhcVers :: [GhcVer] +supportedGhcVers = [minBound .. maxBound] + +-- | Converts 'GhcVer' into dot-separated string. +showGhcVer :: GhcVer -> Text +showGhcVer Ghc7103 = "7.10.3" +showGhcVer Ghc801 = "8.0.1" +showGhcVer Ghc802 = "8.0.2" +showGhcVer Ghc822 = "8.2.2" + +-- | Converts numeric dot-separated GHC version into 'GhcVer'. +parseGhcVer :: Text -> Maybe GhcVer +parseGhcVer "7.10.3" = Just Ghc7103 +parseGhcVer "8.0.1" = Just Ghc801 +parseGhcVer "8.0.2" = Just Ghc802 +parseGhcVer "8.2.2" = Just Ghc822 +parseGhcVer _ = Nothing + +-- | Returns latest known LTS resolver for all GHC versions except default one. +latestLts :: GhcVer -> Text +latestLts Ghc7103 = "6.35" +latestLts Ghc801 = "7.24" +latestLts Ghc802 = "9.21" +latestLts Ghc822 = "11.10" + +baseNopreludeVer :: GhcVer -> Text +baseNopreludeVer Ghc7103 = "4.8.0.2" +baseNopreludeVer Ghc801 = "4.9.0.0" +baseNopreludeVer Ghc802 = "4.9.1.0" +baseNopreludeVer Ghc822 = "4.10.1.0" + +data CustomPrelude = Prelude + { cpPackage :: Text + , cpModule :: Text + } deriving (Show) + +data Answer = Y | N + +yesOrNo :: Text -> Maybe Answer +yesOrNo (T.toLower -> answer ) + | T.null answer = Just Y + | answer `elem` ["yes", "y", "ys"] = Just Y + | answer `elem` ["no", "n"] = Just N + | otherwise = Nothing diff --git a/src/Summoner/Question.hs b/src/Summoner/Question.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Question.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module contains function to proper questioning in terminal. + +module Summoner.Question + ( printQuestion + , choose + , chooseYesNo + , chooseYesNoBool + , query + , queryDef + , queryManyRepeatOnFail + , checkUniqueName + + , trueMessage + , falseMessage + ) where + +import System.Directory (doesPathExist, getCurrentDirectory) +import System.FilePath (()) + +import Summoner.Ansi (Color (..), beautyPrint, bold, boldDefault, errorMessage, italic, prompt, + putStrFlush, setColor, warningMessage) +import Summoner.ProjectData (Answer (..), yesOrNo) +import Summoner.Text (headToUpper, intercalateMap) + +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Universum.Unsafe as Unsafe + +---------------------------------------------------------------------------- +-- IO Questioning +---------------------------------------------------------------------------- + +printQuestion :: Text -> [Text] -> IO () +printQuestion question (def:rest) = do + let restSlash = T.intercalate "/" rest + putStrFlush question + boldDefault def + putTextLn $ "/" <> restSlash +printQuestion question [] = T.putStrLn question + +choose :: Text -> [Text] -> IO Text +choose question choices = do + printQuestion question choices + answer <- prompt + if | T.null answer -> pure (Unsafe.head choices) + | answer `elem` choices -> pure answer + | otherwise -> do + errorMessage "This wasn't a valid choice." + choose question choices + +chooseYesNo :: Text -- ^ target + -> IO a -- ^ action for 'Y' answer + -> IO a -- ^ action for 'N' answer + -> IO a +chooseYesNo target yesDo noDo = do + printQuestion ("Add " <> target <> "?") ["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 + +chooseYesNoBool :: Text -> IO Bool +chooseYesNoBool target = chooseYesNo target (pure True) (pure False) + +targetMessage :: Bool -> Text -> IO Bool +targetMessage result target = do + let (color, actionResult) = case result of + False -> (Cyan, " won't be added to the project") + True -> (Green, " will be added to the project") + + beautyPrint [italic, bold, setColor color] $ " " <> headToUpper target + beautyPrint [setColor color] actionResult + putTextLn "" + + pure result + +trueMessage, falseMessage :: Text -> IO Bool +trueMessage = targetMessage True +falseMessage = targetMessage False + +query :: Text -> IO Text +query question = do + T.putStrLn question + answer <- prompt + if | T.null answer -> do + errorMessage "An answer is required." + query question + | otherwise -> pure answer + +queryDef :: Text -> Text -> IO Text +queryDef question defAnswer = do + putStrFlush question + boldDefault defAnswer + putTextLn "" + answer <- prompt + if | T.null answer -> pure defAnswer + | otherwise -> pure answer + +queryManyRepeatOnFail :: forall a . (Text -> Maybe a) -> IO [a] +queryManyRepeatOnFail parser = promptLoop + where + promptLoop :: IO [a] + promptLoop = do + answer <- prompt + let answers = map (id &&& parser) $ words answer -- converts [Text] into [(Text, Maybe a)] + case partitionPairs answers of + Left unparsed -> do + -- TODO: create intercalateMap function + errorMessage $ "Unable to parse the following items: " <> intercalateMap " " quote unparsed + promptLoop + Right results -> pure results + + -- puts only those @c@ into Left list where snd is Nothing; + -- returns Left if at least one second element is Nothing + partitionPairs :: forall x y . [(x, Maybe y)] -> Either [x] [y] + partitionPairs [] = Right [] + partitionPairs ((x, my):xs) = case my of + Just y -> (y:) <$> partitionPairs xs + Nothing -> case partitionPairs xs of + Left fails -> Left (x : fails) + Right _ -> Left [x] + + quote :: Text -> Text + quote t = "'" <> t <> "'" + +checkUniqueName :: Text -> IO Text +checkUniqueName nm = do + curPath <- getCurrentDirectory + 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: " + checkUniqueName newNm + else + pure nm diff --git a/src/Summoner/Template.hs b/src/Summoner/Template.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Template.hs @@ -0,0 +1,574 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module contains functions for stack template creation. + +module Summoner.Template + ( createStackTemplate + ) where + +import NeatInterpolation (text) + +import Summoner.Default (defaultGHC, endLine) +import Summoner.ProjectData (CustomPrelude (..), GhcVer (..), ProjectData (..), baseNopreludeVer, + latestLts, showGhcVer) +import Summoner.Text (intercalateMap, packageToModule) +import Summoner.Tree (TreeFs (..)) + +import qualified Data.Text as T + +---------------------------------------------------------------------------- +-- Stack File Creation +---------------------------------------------------------------------------- + +emptyIfNot :: Bool -> Text -> Text +emptyIfNot p txt = if p then txt else "" + +-- | Creating template file to use in `stack new` command +createStackTemplate :: ProjectData -> TreeFs +createStackTemplate ProjectData{..} = Dir (toString repo) $ + [ File (toString repo <> ".cabal") + ( createCabalTop + <> emptyIfNot isLib createCabalLib + <> emptyIfNot isExe + ( createCabalExe + $ emptyIfNot isLib $ ", " <> repo ) + <> emptyIfNot test createCabalTest + <> emptyIfNot bench + ( createCabalBenchmark + $ emptyIfNot isLib $ ", " <> repo ) + <> emptyIfNot github createCabalGit + ) + , File "README.md" readme + , File "CHANGELOG.md" changelog + , File "LICENSE" licenseText + ] + ++ createCabalFiles + ++ createStackYamls testedVersions + ++ [File ".gitignore" gitignore | github] + ++ [File ".travis.yml" travisYml | travis] + ++ [File "appveyor.yml" appVeyorYml | appVey] + ++ [File "b" scriptSh | script] + where + -- 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| + name: $repo + version: 0.0.0 + description: $description + synopsis: $description + homepage: https://github.com/${owner}/${repo} + bug-reports: https://github.com/${owner}/${repo}/issues + license: $license + license-file: LICENSE + author: $nm + maintainer: $email + copyright: $year $nm + category: $category + build-type: Simple + extra-doc-files: README.md + , CHANGELOG.md + cabal-version: 1.24 + tested-with: $testedGhcs + $endLine + |] + + testedGhcs :: Text + testedGhcs = intercalateMap ", " (mappend "GHC == " . showGhcVer) testedVersions + + defaultExtensions :: Text + defaultExtensions = case extensions of + [] -> "" + xs -> "default-extensions: " <> T.intercalate "\n " xs + + createCabalLib :: Text + createCabalLib = + [text| + library + hs-source-dirs: src + exposed-modules: $libModuleName + $preludeMod + ghc-options: -Wall + 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 + build-depends: $base + $r + $customPreludePack + default-language: Haskell2010 + $defaultExtensions + $endLine + |] + + createCabalTest :: Text + createCabalTest = + [text| + test-suite ${repo}-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: $base + , $repo + $customPreludePack + ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + $defaultExtensions + $endLine + |] + + createCabalBenchmark :: Text -> Text + createCabalBenchmark r = + [text| + benchmark ${repo}-benchmark + type: exitcode-stdio-1.0 + default-language: Haskell2010 + ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N + hs-source-dirs: benchmark + main-is: Main.hs + build-depends: $base + , gauge + $customPreludePack + $r + $defaultExtensions + $endLine + |] + + createCabalGit :: Text + createCabalGit = + [text| + source-repository head + type: git + location: https://github.com/${owner}/${repo}.git + $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| + module Main where + + main :: IO () + main = putStrLn ("Hello, world!" :: String) + $endLine + |] + + createExe :: Text + createExe = + [text| + module Main where + + 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 = + [text| + # $repo + + [![Hackage]($hackageShield)]($hackageLink) + [![Build status](${travisShield})](${travisLink}) + [![Windows build status](${appVeyorShield})](${appVeyorLink}) + [![$license license](${licenseShield})](${licenseLink}) + + $description + $endLine + |] + where + hackageShield :: Text = + "https://img.shields.io/hackage/v/" <> repo <> ".svg" + hackageLink :: Text = + "https://hackage.haskell.org/package/" <> repo + travisShield :: Text = + "https://secure.travis-ci.org/" <> owner <> "/" <> repo <> ".svg" + travisLink :: Text = + "https://travis-ci.org/" <> owner <> "/" <> repo + 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 + licenseShield :: Text = + "https://img.shields.io/badge/license-" <> T.replace "-" "--" license <> "-blue.svg" + licenseLink :: Text = + "https://github.com/" <> owner <> "/" <> repo <> "/blob/master/LICENSE" + + -- 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]. + The change log is available [on GitHub][2]. + + 0.0.0 + ===== + * Initially created. + + [1]: https://pvp.haskell.org + [2]: https://github.com/${owner}/${repo}/releases + $endLine + |] + + -- create travis.yml template + travisYml :: Text + travisYml = + let travisMtr = T.concat (map (travisMatrixItem . showGhcVer) testedVersions) + defGhc = showGhcVer defaultGHC in + [text| + sudo: true + language: haskell + + git: + depth: 5 + + cache: + directories: + - "$$HOME/.stack" + - "$$HOME/build/${owner}/${repo}/.stack-work" + + matrix: + include: + + $travisMtr + + - ghc: $defGhc + env: GHCVER='${defGhc}' STACK_YAML="$$HOME/build/${owner}/${repo}/stack.yaml" + + addons: + apt: + sources: + - sourceline: 'ppa:hvr/ghc' + packages: + - libgmp-dev + + before_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 + + + install: + - travis_wait 30 stack setup --no-terminal + - stack ghc -- --version + + - travis_wait 40 stack build --only-dependencies --no-terminal + - travis_wait 40 stack build --test --bench --haddock --no-run-tests --no-run-benchmarks --no-haddock-deps --no-terminal + + script: + - travis_wait 40 stack build --test --no-terminal + + notifications: + email: false + $endLine + |] + + travisMatrixItem :: Text -> Text + travisMatrixItem ghcV = + [text| + - ghc: ${ghcV} + env: GHCVER='${ghcV}' STACK_YAML="$$HOME/build/${owner}/${repo}/stack-$$GHCVER.yaml" + $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 + Ghc822 -> "" + _ -> "-" <> showGhcVer ghcV + in stackYaml ver (latestLts ghcV) (baseNopreludeVer ghcV) + where + stackYaml :: Text -> Text -> Text -> TreeFs + stackYaml ghc lts baseVer = File (toString $ "stack" <> ghc <> ".yaml") + [text| + resolver: lts-${lts} + + $extraDeps + + ghc-options: + "$$locals": -fhide-source-paths + $endLine + |] + where + extraDeps :: Text + extraDeps = case prelude of + Nothing -> "" + Just _ -> "extra-deps: [base-noprelude-" <> baseVer <> "]" + + + -- 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 + |] + + scriptSh :: Text + scriptSh = + [text| + #!/usr/bin/env bash + set -e + + # DESCRIPTION + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # This script builds the project in a way that is convenient for developers. + # It passes the right flags into right places, builds the project with --fast, + # tidies up and highlights error messages in GHC output. + + # USAGE + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # ./b build whole project with all targets + # ./b -c do stack clean + # ./b -t build and run tests + # ./b -b build and run benchmarks + # ./b --nix use nix to build package + + args='' + test=false + bench=false + with_nix=false + clean=false + + for var in "$$@" + do + # -t = run tests + if [[ $$var == "-t" ]]; then + test=true + # -b = run benchmarks + elif [[ $$var == "-b" ]]; then + bench=true + elif [[ $$var == "--nix" ]]; then + with_nix=true + # -c = clean + elif [[ $$var == "-c" ]]; then + clean=true + else + args="$$args $$var" + fi + done + + # Cleaning project + if [[ $$clean == true ]]; then + echo "Cleaning project..." + stack clean + exit + fi + + if [[ $$no_nix == true ]]; then + args="$$args --nix" + fi + + xperl='$|++; s/(.*) Compiling\s([^\s]+)\s+\(\s+([^\/]+).*/\1 \2/p' + xgrep="((^.*warning.*$|^.*error.*$|^ .*$|^.*can't find source.*$|^Module imports form a cycle.*$|^ which imports.*$)|^)" + + stack build $$args \ + --ghc-options="+RTS -A256m -n2m -RTS" \ + --test \ + --no-run-tests \ + --no-haddock-deps \ + --bench \ + --no-run-benchmarks \ + --jobs=4 \ + --dependencies-only + + stack build $$args \ + --fast \ + --ghc-options="+RTS -A256m -n2m -RTS" \ + --test \ + --no-run-tests \ + --no-haddock-deps \ + --bench \ + --no-run-benchmarks \ + --jobs=4 2>&1 | perl -pe "$$xperl" | { grep -E --color "$$xgrep" || true; } + + if [[ $$test == true ]]; then + stack build $$args \ + --fast \ + --ghc-options="+RTS -A256m -n2m -RTS" \ + --test \ + --no-haddock-deps \ + --bench \ + --no-run-benchmarks \ + --jobs=4 + fi + + if [[ $$bench == true ]]; then + stack build $$args \ + --fast \ + --ghc-options="+RTS -A256m -n2m -RTS" \ + --test \ + --no-run-tests \ + --no-haddock-deps \ + --bench \ + --jobs=4 + fi + $endLine + |] diff --git a/src/Summoner/Text.hs b/src/Summoner/Text.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Text.hs @@ -0,0 +1,23 @@ +module Summoner.Text + ( packageToModule + , intercalateMap + , headToUpper + ) where + +import qualified Data.Char as C +import qualified Data.Text as T + +-- | Creates module name from the name of the package +-- Ex: @my-lovely-project@ — @MyLovelyProject@ +packageToModule :: Text -> Text +packageToModule = T.concat . map headToUpper . T.splitOn "-" + +-- | Converts every element of list into 'Text' and then joins every element +-- into single 'Text' like 'T.intercalate'. +intercalateMap :: Text -> (a -> Text) -> [a] -> Text +intercalateMap between showT = T.intercalate between . map showT + +headToUpper :: Text -> Text +headToUpper t = case T.uncons t of + Nothing -> "" + Just (x, xs) -> T.cons (C.toUpper x) xs diff --git a/src/Summoner/Tree.hs b/src/Summoner/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Tree.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ViewPatterns #-} + +module Summoner.Tree + ( TreeFs (..) + , traverseTree + , showTree + ) where + +import System.Directory (createDirectoryIfMissing, withCurrentDirectory) + +-- | Describes simple structure of filesystem tree. +data TreeFs + -- | Name of directory (relative) and its containing entries + = Dir FilePath [TreeFs] + -- | File name (relative) and file content + | File FilePath Text + +-- | Walks through directory tree and write file contents, creating all +-- intermediate directories. +traverseTree :: TreeFs -> IO () +traverseTree (Dir name children) = do + createDirectoryIfMissing False name + withCurrentDirectory name $ for_ children traverseTree +traverseTree (File name content) = writeFile name content + +-- | Pretty shows the directory tree content. +showTree :: TreeFs -> Text +showTree = unlines . showOne " " "" "" + +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 + nodeRep :: Text + nodeRep = leader <> arm <> tie <> toText fp + + 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) + +-- For sorting in alphabetic order. +treeFp :: TreeFs -> FilePath +treeFp (Dir fp _) = fp +treeFp (File fp _) = fp diff --git a/src/Summoner/Validation.hs b/src/Summoner/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Validation.hs @@ -0,0 +1,27 @@ +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) diff --git a/summoner.cabal b/summoner.cabal new file mode 100644 --- /dev/null +++ b/summoner.cabal @@ -0,0 +1,96 @@ +name: summoner +version: 1.0.0 +synopsis: Tool for creating completely configured production Haskell projects. +description: Tool for creating completely configured production Haskell projects. + See README.md 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 Kowainik +category: CLI, CLI Tool, Development +build-type: Simple +stability: stable +extra-doc-files: README.md + , CHANGELOG.md +cabal-version: 2.0 +tested-with: GHC == 8.2.2 + , GHC == 8.4.2 + +source-repository head + type: git + location: git@github.com:kowainik/summoner.git + +library + hs-source-dirs: src + exposed-modules: Prelude + Summoner + Summoner.Ansi + Summoner.CLI + Summoner.Config + Summoner.Default + Summoner.License + Summoner.Process + Summoner.Project + Summoner.ProjectData + Summoner.Question + Summoner.Template + Summoner.Text + Summoner.Tree + Summoner.Validation + + other-modules: Paths_summoner + autogen-modules: Paths_summoner + + ghc-options: -Wall + build-depends: base-noprelude >= 4.9 && < 5 + , aeson + , ansi-terminal + , bytestring + , directory + , filepath + , generic-deriving + , neat-interpolation + , optparse-applicative + , process + , text + , time + , tomland + , universum >= 1.2.0 + + default-extensions: DeriveGeneric + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + OverloadedStrings + RecordWildCards + + default-language: Haskell2010 + +executable summon + hs-source-dirs: app + main-is: Main.hs + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: base-noprelude + , summoner + default-language: Haskell2010 + +test-suite summoner-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + + main-is: Spec.hs + other-modules: Test.DecisionSpec + + build-tool-depends: tasty-discover:tasty-discover + build-depends: base-noprelude + , hedgehog + , tasty + , tasty-hedgehog + , summoner + , universum + + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/test/Test/DecisionSpec.hs b/test/Test/DecisionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/DecisionSpec.hs @@ -0,0 +1,25 @@ +module Test.DecisionSpec where + +import Hedgehog (MonadGen, forAll, property, (===)) +import Test.Tasty (TestTree) +import Test.Tasty.Hedgehog (testProperty) + +import Summoner.ProjectData (Decision) + +import qualified Hedgehog.Gen as Gen + +test_decisionSemigroupAssoc :: [TestTree] +test_decisionSemigroupAssoc = pure $ testProperty "Decision Semigroup:Assoc" $ 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 + x <- forAll genDecision + x <> mempty === x + mempty <> x === x + +genDecision :: MonadGen m => m Decision +genDecision = Gen.enumBounded