summoner (empty) → 1.0.0
raw patch · 23 files changed
+2584/−0 lines, 23 filesdep +aesondep +ansi-terminaldep +base-nopreludesetup-changed
Dependencies added: aeson, ansi-terminal, base-noprelude, bytestring, directory, filepath, generic-deriving, hedgehog, neat-interpolation, optparse-applicative, process, summoner, tasty, tasty-hedgehog, text, time, tomland, universum
Files
- CHANGELOG.md +53/−0
- LICENSE +373/−0
- README.md +231/−0
- Setup.hs +2/−0
- app/Main.hs +8/−0
- src/Prelude.hs +7/−0
- src/Summoner.hs +27/−0
- src/Summoner/Ansi.hs +82/−0
- src/Summoner/CLI.hs +263/−0
- src/Summoner/Config.hs +198/−0
- src/Summoner/Default.hs +37/−0
- src/Summoner/License.hs +49/−0
- src/Summoner/Process.hs +32/−0
- src/Summoner/Project.hs +165/−0
- src/Summoner/ProjectData.hs +121/−0
- src/Summoner/Question.hs +141/−0
- src/Summoner/Template.hs +574/−0
- src/Summoner/Text.hs +23/−0
- src/Summoner/Tree.hs +49/−0
- src/Summoner/Validation.hs +27/−0
- summoner.cabal +96/−0
- test/Spec.hs +1/−0
- test/Test/DecisionSpec.hs +25/−0
+ CHANGELOG.md view
@@ -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`.
+ LICENSE view
@@ -0,0 +1,373 @@+Mozilla Public License Version 2.0+==================================++1. Definitions+--------------++1.1. "Contributor"+ means each individual or legal entity that creates, contributes to+ the creation of, or owns Covered Software.++1.2. "Contributor Version"+ means the combination of the Contributions of others (if any) used+ by a Contributor and that particular Contributor's Contribution.++1.3. "Contribution"+ means Covered Software of a particular Contributor.++1.4. "Covered Software"+ means Source Code Form to which the initial Contributor has attached+ the notice in Exhibit A, the Executable Form of such Source Code+ Form, and Modifications of such Source Code Form, in each case+ including portions thereof.++1.5. "Incompatible With Secondary Licenses"+ means++ (a) that the initial Contributor has attached the notice described+ in Exhibit B to the Covered Software; or++ (b) that the Covered Software was made available under the terms of+ version 1.1 or earlier of the License, but not also under the+ terms of a Secondary License.++1.6. "Executable Form"+ means any form of the work other than Source Code Form.++1.7. "Larger Work"+ means a work that combines Covered Software with other material, in+ a separate file or files, that is not Covered Software.++1.8. "License"+ means this document.++1.9. "Licensable"+ means having the right to grant, to the maximum extent possible,+ whether at the time of the initial grant or subsequently, any and+ all of the rights conveyed by this License.++1.10. "Modifications"+ means any of the following:++ (a) any file in Source Code Form that results from an addition to,+ deletion from, or modification of the contents of Covered+ Software; or++ (b) any new file in Source Code Form that contains any Covered+ Software.++1.11. "Patent Claims" of a Contributor+ means any patent claim(s), including without limitation, method,+ process, and apparatus claims, in any patent Licensable by such+ Contributor that would be infringed, but for the grant of the+ License, by the making, using, selling, offering for sale, having+ made, import, or transfer of either its Contributions or its+ Contributor Version.++1.12. "Secondary License"+ means either the GNU General Public License, Version 2.0, the GNU+ Lesser General Public License, Version 2.1, the GNU Affero General+ Public License, Version 3.0, or any later versions of those+ licenses.++1.13. "Source Code Form"+ means the form of the work preferred for making modifications.++1.14. "You" (or "Your")+ means an individual or a legal entity exercising rights under this+ License. For legal entities, "You" includes any entity that+ controls, is controlled by, or is under common control with You. For+ purposes of this definition, "control" means (a) the power, direct+ or indirect, to cause the direction or management of such entity,+ whether by contract or otherwise, or (b) ownership of more than+ fifty percent (50%) of the outstanding shares or beneficial+ ownership of such entity.++2. License Grants and Conditions+--------------------------------++2.1. Grants++Each Contributor hereby grants You a world-wide, royalty-free,+non-exclusive license:++(a) under intellectual property rights (other than patent or trademark)+ Licensable by such Contributor to use, reproduce, make available,+ modify, display, perform, distribute, and otherwise exploit its+ Contributions, either on an unmodified basis, with Modifications, or+ as part of a Larger Work; and++(b) under Patent Claims of such Contributor to make, use, sell, offer+ for sale, have made, import, and otherwise transfer either its+ Contributions or its Contributor Version.++2.2. Effective Date++The licenses granted in Section 2.1 with respect to any Contribution+become effective for each Contribution on the date the Contributor first+distributes such Contribution.++2.3. Limitations on Grant Scope++The licenses granted in this Section 2 are the only rights granted under+this License. No additional rights or licenses will be implied from the+distribution or licensing of Covered Software under this License.+Notwithstanding Section 2.1(b) above, no patent license is granted by a+Contributor:++(a) for any code that a Contributor has removed from Covered Software;+ or++(b) for infringements caused by: (i) Your and any other third party's+ modifications of Covered Software, or (ii) the combination of its+ Contributions with other software (except as part of its Contributor+ Version); or++(c) under Patent Claims infringed by Covered Software in the absence of+ its Contributions.++This License does not grant any rights in the trademarks, service marks,+or logos of any Contributor (except as may be necessary to comply with+the notice requirements in Section 3.4).++2.4. Subsequent Licenses++No Contributor makes additional grants as a result of Your choice to+distribute the Covered Software under a subsequent version of this+License (see Section 10.2) or under the terms of a Secondary License (if+permitted under the terms of Section 3.3).++2.5. Representation++Each Contributor represents that the Contributor believes its+Contributions are its original creation(s) or it has sufficient rights+to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use++This License is not intended to limit any rights You have under+applicable copyright doctrines of fair use, fair dealing, or other+equivalents.++2.7. Conditions++Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted+in Section 2.1.++3. Responsibilities+-------------------++3.1. Distribution of Source Form++All distribution of Covered Software in Source Code Form, including any+Modifications that You create or to which You contribute, must be under+the terms of this License. You must inform recipients that the Source+Code Form of the Covered Software is governed by the terms of this+License, and how they can obtain a copy of this License. You may not+attempt to alter or restrict the recipients' rights in the Source Code+Form.++3.2. Distribution of Executable Form++If You distribute Covered Software in Executable Form then:++(a) such Covered Software must also be made available in Source Code+ Form, as described in Section 3.1, and You must inform recipients of+ the Executable Form how they can obtain a copy of such Source Code+ Form by reasonable means in a timely manner, at a charge no more+ than the cost of distribution to the recipient; and++(b) You may distribute such Executable Form under the terms of this+ License, or sublicense it under different terms, provided that the+ license for the Executable Form does not attempt to limit or alter+ the recipients' rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work++You may create and distribute a Larger Work under terms of Your choice,+provided that You also comply with the requirements of this License for+the Covered Software. If the Larger Work is a combination of Covered+Software with a work governed by one or more Secondary Licenses, and the+Covered Software is not Incompatible With Secondary Licenses, this+License permits You to additionally distribute such Covered Software+under the terms of such Secondary License(s), so that the recipient of+the Larger Work may, at their option, further distribute the Covered+Software under the terms of either this License or such Secondary+License(s).++3.4. Notices++You may not remove or alter the substance of any license notices+(including copyright notices, patent notices, disclaimers of warranty,+or limitations of liability) contained within the Source Code Form of+the Covered Software, except that You may alter any license notices to+the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms++You may choose to offer, and to charge a fee for, warranty, support,+indemnity or liability obligations to one or more recipients of Covered+Software. However, You may do so only on Your own behalf, and not on+behalf of any Contributor. You must make it absolutely clear that any+such warranty, support, indemnity, or liability obligation is offered by+You alone, and You hereby agree to indemnify every Contributor for any+liability incurred by such Contributor as a result of warranty, support,+indemnity or liability terms You offer. You may include additional+disclaimers of warranty and limitations of liability specific to any+jurisdiction.++4. Inability to Comply Due to Statute or Regulation+---------------------------------------------------++If it is impossible for You to comply with any of the terms of this+License with respect to some or all of the Covered Software due to+statute, judicial order, or regulation then You must: (a) comply with+the terms of this License to the maximum extent possible; and (b)+describe the limitations and the code they affect. Such description must+be placed in a text file included with all distributions of the Covered+Software under this License. Except to the extent prohibited by statute+or regulation, such description must be sufficiently detailed for a+recipient of ordinary skill to be able to understand it.++5. Termination+--------------++5.1. The rights granted under this License will terminate automatically+if You fail to comply with any of its terms. However, if You become+compliant, then the rights granted under this License from a particular+Contributor are reinstated (a) provisionally, unless and until such+Contributor explicitly and finally terminates Your grants, and (b) on an+ongoing basis, if such Contributor fails to notify You of the+non-compliance by some reasonable means prior to 60 days after You have+come back into compliance. Moreover, Your grants from a particular+Contributor are reinstated on an ongoing basis if such Contributor+notifies You of the non-compliance by some reasonable means, this is the+first time You have received notice of non-compliance with this License+from such Contributor, and You become compliant prior to 30 days after+Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent+infringement claim (excluding declaratory judgment actions,+counter-claims, and cross-claims) alleging that a Contributor Version+directly or indirectly infringes any patent, then the rights granted to+You by any and all Contributors for the Covered Software under Section+2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all+end user license agreements (excluding distributors and resellers) which+have been validly granted by You or Your distributors under this License+prior to termination shall survive termination.++************************************************************************+* *+* 6. Disclaimer of Warranty *+* ------------------------- *+* *+* Covered Software is provided under this License on an "as is" *+* basis, without warranty of any kind, either expressed, implied, or *+* statutory, including, without limitation, warranties that the *+* Covered Software is free of defects, merchantable, fit for a *+* particular purpose or non-infringing. The entire risk as to the *+* quality and performance of the Covered Software is with You. *+* Should any Covered Software prove defective in any respect, You *+* (not any Contributor) assume the cost of any necessary servicing, *+* repair, or correction. This disclaimer of warranty constitutes an *+* essential part of this License. No use of any Covered Software is *+* authorized under this License except under this disclaimer. *+* *+************************************************************************++************************************************************************+* *+* 7. Limitation of Liability *+* -------------------------- *+* *+* Under no circumstances and under no legal theory, whether tort *+* (including negligence), contract, or otherwise, shall any *+* Contributor, or anyone who distributes Covered Software as *+* permitted above, be liable to You for any direct, indirect, *+* special, incidental, or consequential damages of any character *+* including, without limitation, damages for lost profits, loss of *+* goodwill, work stoppage, computer failure or malfunction, or any *+* and all other commercial damages or losses, even if such party *+* shall have been informed of the possibility of such damages. This *+* limitation of liability shall not apply to liability for death or *+* personal injury resulting from such party's negligence to the *+* extent applicable law prohibits such limitation. Some *+* jurisdictions do not allow the exclusion or limitation of *+* incidental or consequential damages, so this exclusion and *+* limitation may not apply to You. *+* *+************************************************************************++8. Litigation+-------------++Any litigation relating to this License may be brought only in the+courts of a jurisdiction where the defendant maintains its principal+place of business and such litigation shall be governed by laws of that+jurisdiction, without reference to its conflict-of-law provisions.+Nothing in this Section shall prevent a party's ability to bring+cross-claims or counter-claims.++9. Miscellaneous+----------------++This License represents the complete agreement concerning the subject+matter hereof. If any provision of this License is held to be+unenforceable, such provision shall be reformed only to the extent+necessary to make it enforceable. Any law or regulation which provides+that the language of a contract shall be construed against the drafter+shall not be used to construe this License against a Contributor.++10. Versions of the License+---------------------------++10.1. New Versions++Mozilla Foundation is the license steward. Except as provided in Section+10.3, no one other than the license steward has the right to modify or+publish new versions of this License. Each version will be given a+distinguishing version number.++10.2. Effect of New Versions++You may distribute the Covered Software under the terms of the version+of the License under which You originally received the Covered Software,+or under the terms of any subsequent version published by the license+steward.++10.3. Modified Versions++If you create software not governed by this License, and you want to+create a new license for such software, you may create and use a+modified version of this License if you rename the license and remove+any references to the name of the license steward (except to note that+such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary+Licenses++If You choose to distribute Source Code Form that is Incompatible With+Secondary Licenses under the terms of this version of the License, the+notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+-------------------------------------------++ This Source Code Form is subject to the terms of the Mozilla Public+ License, v. 2.0. If a copy of the MPL was not distributed with this+ file, You can obtain one at http://mozilla.org/MPL/2.0/.++If it is not possible or desirable to put the notice in a particular+file, then You may include the notice in a location (such as a LICENSE+file in a relevant directory) where a recipient would be likely to look+for such a notice.++You may add additional accurate notices of copyright ownership.++Exhibit B - "Incompatible With Secondary Licenses" Notice+---------------------------------------------------------++ This Source Code Form is "Incompatible With Secondary Licenses", as+ defined by the Mozilla Public License, v. 2.0.
+ README.md view
@@ -0,0 +1,231 @@+# :crystal_ball: Summoner++[](http://travis-ci.org/kowainik/summoner)+[](https://ci.appveyor.com/project/kowainik/summoner)+[](https://github.com/kowainik/summoner/blob/master/LICENSE)+[](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++[++## 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import System.IO (hSetEncoding, utf8)++import Summoner (summon)++main :: IO ()+main = hSetEncoding stdout utf8 >> summon
+ src/Prelude.hs view
@@ -0,0 +1,7 @@+-- | Uses [universum](http://hackage.haskell.org/package/universum) as default prelude.++module Prelude+ ( module Universum+ ) where++import Universum hiding (Key)
+ src/Summoner.hs view
@@ -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
+ src/Summoner/Ansi.hs view
@@ -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
+ src/Summoner/CLI.hs view
@@ -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+|]
+ src/Summoner/Config.hs view
@@ -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
+ src/Summoner/Default.hs view
@@ -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"
+ src/Summoner/License.hs view
@@ -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
+ src/Summoner/Process.hs view
@@ -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)
+ src/Summoner/Project.hs view
@@ -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")
+ src/Summoner/ProjectData.hs view
@@ -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
+ src/Summoner/Question.hs view
@@ -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
+ src/Summoner/Template.hs view
@@ -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++ []($hackageLink)+ [](${travisLink})+ [](${appVeyorLink})+ [](${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+ |]
+ src/Summoner/Text.hs view
@@ -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
+ src/Summoner/Tree.hs view
@@ -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
+ src/Summoner/Validation.hs view
@@ -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)
+ summoner.cabal view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
+ test/Test/DecisionSpec.hs view
@@ -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