diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,54 @@ # Summoner +1.1.0 +===== + +* [#128](https://github.com/kowainik/summoner/issues/128): + __Important:__ Replace `summon` with `summon new` command. + To create a project now the following command should be used: + ``` + summon new my-project + ``` +* [#82](https://github.com/kowainik/summoner/issues/82): + Add stackage badges. +* [#109](https://github.com/kowainik/summoner/issues/109): + Fix travis cache directories. +* [#117](https://github.com/kowainik/summoner/issues/117): + Step into created project properly +* [#110](https://github.com/kowainik/summoner/issues/110): + Print executing command. +* [#91](https://github.com/kowainik/summoner/issues/91): + Add warning fields for ghc. +* [#90](https://github.com/kowainik/summoner/issues/90): + Add TOML test. +* [#120](https://github.com/kowainik/summoner/issues/120): + Bump up dependencies. +* [#58](https://github.com/kowainik/summoner/issues/58): + Make `Licence` type safer. +* [#124](https://github.com/kowainik/summoner/issues/124): + Print directories bold. +* [#130](https://github.com/kowainik/summoner/issues/130): + Show git revision version under `--version` command. +* [#63](https://github.com/kowainik/summoner/issues/63): + Add `show ghc`, `show license` and `show license ` commands. +* [#122](https://github.com/kowainik/summoner/issues/122): + Remove github link from CHANGELOG when github is not chosen. +* [#35](https://github.com/kowainik/summoner/issues/35): + Add config option to add `.stylish-haskell.yaml` to your project + (via URL or file path). +* Bump up `tomland` version to `0.4.0`. +* [#138](https://github.com/kowainik/summoner/issues/138): + Remove traces of GitHub from `.cabal` file when GitHub integration is disabled. +* [#31](https://github.com/kowainik/summoner/issues/31): + Add config option to add `CONTRIBUTING.md` to your project + (via URL or file path). +* [#27](https://github.com/kowainik/summoner/issues/27): + Remove `b` script. + 1.0.6 ===== -* Use `relude` instead of `universum` +* Use `relude` instead of `universum`. * [#105](https://github.com/kowainik/summoner/issues/105): Add `--ignore-config` option. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,58 +1,71 @@ # 🔮 Summoner +![wizard](https://user-images.githubusercontent.com/8126674/44388234-320aac00-a55a-11e8-879d-5dca68512031.png) [![Build status](https://secure.travis-ci.org/kowainik/summoner.svg)](http://travis-ci.org/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) [![Stackage LTS](http://stackage.org/package/summoner/badge/lts)](http://stackage.org/lts/package/summoner) [![Stackage Nightly](http://stackage.org/package/summoner/badge/nightly)](http://stackage.org/nightly/package/summoner) +[![Hackage-Deps](https://img.shields.io/hackage-deps/v/summoner.svg)](http://packdeps.haskellers.com/reverse/summoner) -This is tool for creating completely configured production Haskell projects. +> _So many of our dreams at first seem impossible, then they seem improbable, and +> then, when we summon the will, they soon become inevitable._ +> +> Christopher Reeve +Summoner is the tool for creating fully configured production Haskell projects. + ## Demo -[![asciicast](https://asciinema.org/a/PCt492vIY7ccuNw3qBJFM9q9G.png)](https://asciinema.org/a/PCt492vIY7ccuNw3qBJFM9q9G) +[![asciicast](https://asciinema.org/a/198918.png)](https://asciinema.org/a/198918) ## Getting started ### Prerequisites -To start using it make sure you have next tools installed on your machine: +To start using it make sure you have the next tools installed on your machine: * [`Stack`](http://haskellstack.org) or [`cabal`](https://www.haskell.org/cabal/) * [`git`](https://git-scm.com) * [`hub`](https://github.com/github/hub) +* [`curl`](https://curl.haxx.se) ### Installation -Installation process can be done with one simple command: +The installation process can be done with the one simple command: - $ cabal install summoner + $ cabal new-install summoner or $ stack install summoner +or directly from GitHub. + 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). +After that, you can call `summon` with the required command. To create a +project, use `summon new` command specifying the prefered CLI options, follow +the instructions during the interactive process of the project creation, and a +new project would be created in a subfolder as well as a repository under your +GitHub account (if requested). ### Usage -There are several options how to set particular configurations: +There are several options how to set particular configurations for the new projects: 1. Default configuration file (`~/.summoner.toml`). -2. Explicitly specified configuration file by `--file FILENAME` option (used instead of default one if specified). +2. Explicitly specified configuration file by `--file FILENAME` option (used + instead of the default one if specified). 3. Options that are stated by CLI arguments. 4. Interactively inputed answers during work of the `summon` command (for the options that were not specified on previous steps). -So the configuration uses [`Partial Options Monoid Pattern`](https://medium.com/@jonathangfischoff/the-partial-options-monoid-pattern-31914a71fc67). +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. @@ -86,17 +99,25 @@ * `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 [`gauge`](https://hackage.haskell.org/package/gauge) library usage example by default, +* `bench` – `true` if you want to create `benchmark` folder with `Main.hs` file with [`gauge`](https://hackage.haskell.org/package/gauge) + library usage example by default, `false` if you don't. If not specified it would be asked during each run of the `summoner`. * `extensions` – List of the default extensions to add into `default-extensions` section in the `.cabal`. +* `warnings` – List of the default checks and warnings to add into `ghc-options` section in the `.cabal`. +* `stylish.*` — `stylish.file` to provide the absolute file path to the + `.stylish-haskell.yaml` file to use in the project. `stylish.url` to provide + the link to the `.stylish-haskell.yaml` file to use in the project. In case of + the absense or wrong path/link no `.stylish-haskell.yaml` file is created. +* `contributing.*` — `contributing.file` to provide the absolute file path to the + `CONTRIBUTING.md` file to use in the project. `contributing.url` to provide + the link to the `CONTRIBUTING.md` file to use in the project. In case of + the absense or wrong path/link no `CONTRIBUTING` file is created. ###### Custom prelude options @@ -107,25 +128,42 @@ ###### Examples -See example of [configuration for projects of `Kowainik` organization](https://github.com/kowainik/org/blob/master/.summoner.toml). +See an example of [the configuration for projects of the `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. +By default, the `summoner` looks for the configuration file (`.summoner.toml`) in home directory. -The other way to specify some particular `.toml` file is `summon PROJECTNAME --file FILEPATH` command. +The other way to specify some particular `.toml` file is `summon new PROJECTNAME --file FILEPATH` command. ##### CLI -See the basic usage syntax below (you can check it out with `summon --help` command): +Available commands: ``` -summon PROJECT_NAME [--cabal] [--stack] [--ignore-config] - [with [OPTIONS]] [without [OPTIONS]] - [-f|--file FILENAME] [--prelude-package PACKAGE_NAME] - [--prelude-module MODULE_NAME] +Usage: + summon COMMAND + Set up your own Haskell project +Available commands: + new Create a new Haskell project + show Show available licenses or ghc versions + Available global options: -h, --help Show this help text -v, --version Show summoner's version +``` + +**`summon new`** command: + +``` +Usage: + summon new PROJECT_NAME [--cabal] [--stack] [--ignore-config] + [with [OPTIONS]] [without [OPTIONS]] + [-f|--file FILENAME] + [--prelude-package PACKAGE_NAME] + [--prelude-module MODULE_NAME] + +Available options: + -h, --help Show this help text --ignore-config Ignore configuration file --cabal Cabal support for the project --stack Stack support for the project @@ -143,54 +181,60 @@ without Specify options to disable Available command options: - -h,--help Show this help text + -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 +``` +**`summon show`** command: + ``` +Usage: + summon show COMMAND + Show supported licenses or ghc versions +Available commands: + ghc Show available ghc versions + license Show available licenses + license [LICENSE_NAME] Show specific license text + +Available options: + -h, --help Show this help text +``` + 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. +If any of the applicable command options wasn't tagged as enabled/disabled, then +the question is asked during the work of the tool. For example, ``` - summon newProject with -letgcspw without -b --prelude-package relude --prelude-module Relude + summon new my-project with -letgcpw without -b --prelude-package relude --prelude-module Relude ``` -will create fully functional project which uses custom prelude `relude`, contains -library, executable file, tests, [build script](#build-script) -and create private repository on [github](https://github.com) + +creates the fully functional project which uses custom prelude `relude`, contains +library, executable file, tests and create private repository on [github](https://github.com) integrated with `Travis-CI`, `AppVeyor-CI`, but benchmarks won't be attached to this one. But when calling this command ``` - summon newProject + summon new my-project ``` -the tool will ask about every particular option, rather you'd like to have it +the tool asks 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: +hierarchy is created: ``` project-name @@ -214,30 +258,40 @@ ├── .gitignore └── .travis.yml ``` -and also repository with one commit at master will be added with enabled `Travis-CI` for that. -### Build script +Moreover, a repository with one commit at master is added with enabled Travis CI for that. -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. +## GHC options -#### Usage +The `-Wall` option is added to every stanza. -``` - ./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 -``` +The following warning checks are added by default to executable, tests and benchmark stanzas: + -threaded + -rtsopts + -with-rtsopts=-N + +If warnings are not explicitly stated in the configuration file, then the +following ghc-options are added to all stanzas. + + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints (ghc >= 8.0) + -fhide-source-paths (ghc >= 8.2.2) + -Wmissing-export-lists (ghc >= 8.4.1) + -Wpartial-fields (ghc >= 8.4.1) + ## Change log -[List of changes](https://github.com/kowainik/summoner/blob/master/CHANGELOG.md). +[List of changes](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 it's using -[`cabal`](https://www.haskell.org/cabal/) for creating projects. +which is the tool with the same goal but it's only for creating cabal projects. + +Icons made by [Nikita Golubev](https://www.flaticon.com/authors/nikita-golubev) +from [Flaticon](https://www.flaticon.com/) is licensed by +[CC 3.0 BY](http://creativecommons.org/licenses/by/3.0/). diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/src/Summoner/Ansi.hs b/src/Summoner/Ansi.hs --- a/src/Summoner/Ansi.hs +++ b/src/Summoner/Ansi.hs @@ -4,11 +4,15 @@ ( Color (..) , putStrFlush , beautyPrint + , boldCode + , blueCode , bold , boldText , boldDefault , italic + , redCode , reset + , resetCode , prompt , setColor , successMessage @@ -21,7 +25,7 @@ import Relude import System.Console.ANSI (Color (..), ColorIntensity (Vivid), ConsoleIntensity (BoldIntensity), - ConsoleLayer (Foreground), SGR (..), setSGR) + ConsoleLayer (Foreground), SGR (..), setSGR, setSGRCode) import System.IO (hFlush) ---------------------------------------------------------------------------- @@ -82,3 +86,9 @@ successMessage = colorMessage Green infoMessage = colorMessage Blue skipMessage = colorMessage Cyan + +blueCode, boldCode, redCode, resetCode :: String +redCode = setSGRCode [SetColor Foreground Vivid Red] +blueCode = setSGRCode [SetColor Foreground Vivid Blue] +boldCode = setSGRCode [SetConsoleIntensity BoldIntensity] +resetCode = setSGRCode [Reset] diff --git a/src/Summoner/CLI.hs b/src/Summoner/CLI.hs --- a/src/Summoner/CLI.hs +++ b/src/Summoner/CLI.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} -- | This module contains functions and data types to parse CLI inputs. @@ -9,8 +10,10 @@ ) where import Relude +import Relude.Extra.Enum (universe) import Data.Version (showVersion) +import Development.GitRev (gitCommitDate, gitDirty, gitHash) import NeatInterpolation (text) import Options.Applicative (Parser, ParserInfo, command, execParser, flag, fullDesc, help, helper, info, infoFooter, infoHeader, infoOption, long, metavar, optional, @@ -19,24 +22,55 @@ import System.Directory (doesFileExist) import Paths_summoner (version) -import Summoner.Ansi (Color (Green), beautyPrint, bold, errorMessage, infoMessage, setColor, - warningMessage) +import Summoner.Ansi (Color (Green), beautyPrint, blueCode, bold, boldCode, errorMessage, + infoMessage, redCode, resetCode, setColor, warningMessage) import Summoner.Config (ConfigP (..), PartialConfig, defaultConfig, finalise, loadFileConfig) +import Summoner.Decision (Decision (..)) import Summoner.Default (defaultConfigFile, endLine) +import Summoner.GhcVer (GhcVer, showGhcVer) +import Summoner.License (License (..), LicenseName (..), fetchLicense, parseLicenseName) import Summoner.Project (generateProject) -import Summoner.ProjectData (CustomPrelude (..), Decision (..)) +import Summoner.ProjectData (CustomPrelude (..)) import Summoner.Validation (Validation (..)) +import qualified Data.Text as T + --------------------------------------------------------------------------- -- CLI ---------------------------------------------------------------------------- summon :: IO () -summon = execParser prsr >>= runWithOptions +summon = execParser prsr >>= runCommand --- | Run 'hs-init' with cli options -runWithOptions :: InitOpts -> IO () -runWithOptions InitOpts{..} = do +-- | Run 'summoner' with cli command +runCommand :: Command -> IO () +runCommand = \case + New opts -> runNew opts + ShowInfo opts -> runShow opts + +runShow :: ShowOpts -> IO () +runShow = \case + -- show list of all available GHC versions + GhcList -> showBulletList @GhcVer showGhcVer (reverse universe) + -- show a list of all available licenses + LicenseList Nothing -> showBulletList @LicenseName show universe + -- show a specific license + LicenseList (Just name) -> + case parseLicenseName (toText name) of + Nothing -> do + errorMessage "This wasn't a valid choice." + infoMessage "Here is the list of supported licenses:" + showBulletList @LicenseName show universe + -- get and show a license`s text + Just licenseName -> do + fetchedLicense <- fetchLicense licenseName + putTextLn $ unLicense fetchedLicense + where + showBulletList :: (a -> Text) -> [a] -> IO () + showBulletList showT = mapM_ (infoMessage . T.append "➤ " . showT) + +runNew :: NewOpts -> IO () +runNew NewOpts{..} = do -- read config from file fileConfig <- readFileConfig ignoreFile maybeFile @@ -75,21 +109,105 @@ errorMessage $ "Specified configuration file " <> toText file <> " is not found." exitFailure --- | Initial parsed options from cli -data InitOpts = InitOpts +---------------------------------------------------------------------------- +-- Command data types +---------------------------------------------------------------------------- + +-- | Represent all available commands +data Command + -- | @new@ command creates a new project + = New NewOpts + -- | @show@ command shows supported licenses or GHC versions + | ShowInfo ShowOpts + +-- | Options parsed with @new@ command +data NewOpts = NewOpts { projectName :: Text -- ^ project name , ignoreFile :: Bool -- ^ ignore all config files if 'True' , maybeFile :: Maybe FilePath -- ^ file with custom configuration , cliConfig :: PartialConfig -- ^ config gathered during CLI } +-- | Commands parsed with @show@ command +data ShowOpts = GhcList | LicenseList (Maybe String) + +---------------------------------------------------------------------------- +-- Parsers +---------------------------------------------------------------------------- + +-- | Main parser of the app. +prsr :: ParserInfo Command +prsr = modifyHeader + $ modifyFooter + $ info ( helper <*> versionP <*> summonerP ) + $ fullDesc + <> progDesc "Set up your own Haskell project" + +versionP :: Parser (a -> a) +versionP = infoOption summonerVersion + $ long "version" + <> short 'v' + <> help "Show summoner's version" + +summonerVersion :: String +summonerVersion = toString $ intercalate "\n" $ [sVersion, sHash, sDate] ++ [sDirty | $(gitDirty)] + where + sVersion = blueCode <> boldCode <> "Summoner " <> "v" <> showVersion version <> resetCode + sHash = " ➤ " <> blueCode <> boldCode <> "Git revision: " <> resetCode <> $(gitHash) + sDate = " ➤ " <> blueCode <> boldCode <> "Commit date: " <> resetCode <> $(gitCommitDate) + sDirty = redCode <> "There are non-committed files." <> resetCode + +-- All possible commands. +summonerP :: Parser Command +summonerP = subparser + $ command "new" (info (helper <*> newP) $ progDesc "Create a new Haskell project") + <> command "show" (info (helper <*> showP) $ progDesc "Show supported licenses or ghc versions") + +---------------------------------------------------------------------------- +-- Show command parsers +---------------------------------------------------------------------------- + +-- | Parses options of the @show@ command. +showP :: Parser Command +showP = ShowInfo <$> subparser + ( command "ghc" (info (helper <*> pure GhcList) $ progDesc "Show supported ghc versions") + <> command "license" (info (helper <*> licenseText) $ progDesc "Show supported licenses") + ) + +licenseText :: Parser ShowOpts +licenseText = LicenseList <$> optional + (strArgument (metavar "LICENSE_NAME" <> help "Show specific license text")) + +---------------------------------------------------------------------------- +-- New command parsers +---------------------------------------------------------------------------- + +-- | Parses options of the @new@ command. +newP :: Parser Command +newP = do + projectName <- strArgument (metavar "PROJECT_NAME") + ignoreFile <- ignoreFileP + cabal <- cabalP + stack <- stackP + with <- optional withP + without <- optional withoutP + file <- optional fileP + preludePack <- optional preludePackP + preludeMod <- optional preludeModP + + pure $ New $ NewOpts projectName ignoreFile file + $ (maybeToMonoid $ with <> without) + { cPrelude = Last $ Prelude <$> preludePack <*> preludeMod + , cCabal = cabal + , cStack = stack + } + 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 @@ -99,7 +217,6 @@ , cTravis = cTravis , cAppVey = cAppVey , cPrivate= cPrivate - , cScript = cScript , cLib = cLib , cExe = cExe , cTest = cTest @@ -130,12 +247,6 @@ <> 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" @@ -149,10 +260,10 @@ <> help "Executable target" testP :: Decision -> Parser Decision -testP d = flag Idk d - $ long "test" - <> short 't' - <> help "Test target" +testP d = flag Idk d + $ long "test" + <> short 't' + <> help "Test target" benchmarkP :: Decision -> Parser Decision benchmarkP d = flag Idk d @@ -204,49 +315,17 @@ $ long "stack" <> help "Stack support for the project" -optsP :: Parser InitOpts -optsP = do - projectName <- strArgument (metavar "PROJECT_NAME") - ignoreFile <- ignoreFileP - cabal <- cabalP - stack <- stackP - with <- optional withP - without <- optional withoutP - file <- optional fileP - preludePack <- optional preludePackP - preludeMod <- optional preludeModP - - pure $ InitOpts projectName ignoreFile file - $ (maybeToMonoid $ with <> without) - { cPrelude = Last $ Prelude <$> preludePack <*> preludeMod - , cCabal = cabal - , cStack = stack - } - -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" +---------------------------------------------------------------------------- +-- Beauty util +---------------------------------------------------------------------------- -- to put custom header which doesn't cut all spaces -modifyHeader :: ParserInfo InitOpts -> ParserInfo InitOpts -modifyHeader initOpts = initOpts {infoHeader = stringChunk $ toString artHeader} +modifyHeader :: ParserInfo a -> ParserInfo a +modifyHeader p = p {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} +modifyFooter :: ParserInfo a -> ParserInfo a +modifyFooter p = p {infoFooter = stringChunk $ toString artFooter} artHeader :: Text artHeader = [text| diff --git a/src/Summoner/Config.hs b/src/Summoner/Config.hs --- a/src/Summoner/Config.hs +++ b/src/Summoner/Config.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -17,6 +16,7 @@ , PartialConfig , Config + , configT , defaultConfig , finalise @@ -30,11 +30,13 @@ import Data.Monoid (Last (..)) import Generics.Deriving.Monoid (GMonoid, gmemptydefault) import Generics.Deriving.Semigroup (GSemigroup, gsappenddefault) -import Toml (AnyValue (..), BiToml, Key, Prism (..), dimap, (.=)) +import Toml (AnyValue (..), BiMap (..), BiToml, Bijection (..), Key, dimap, (.=)) -import Summoner.License (License (..)) -import Summoner.ProjectData (CustomPrelude (..), Decision (..), GhcVer (..), parseGhcVer, - showGhcVer) +import Summoner.Decision (Decision (..)) +import Summoner.GhcVer (GhcVer (..), parseGhcVer, showGhcVer) +import Summoner.License (LicenseName (..), parseLicenseName) +import Summoner.ProjectData (CustomPrelude (..)) +import Summoner.Source (Source, sourceT) import Summoner.Validation (Validation (..)) import qualified Text.Show as Show @@ -44,28 +46,48 @@ -- | Potentially incomplete configuration. data ConfigP (p :: Phase) = Config - { cOwner :: p :- Text - , cFullName :: p :- Text - , cEmail :: p :- Text - , cLicense :: p :- License - , cGhcVer :: p :- [GhcVer] - , cCabal :: Decision - , cStack :: Decision - , cGitHub :: Decision - , cTravis :: Decision - , cAppVey :: Decision - , cPrivate :: Decision - , cScript :: Decision - , cLib :: Decision - , cExe :: Decision - , cTest :: Decision - , cBench :: Decision - , cPrelude :: Last CustomPrelude - , cExtensions :: [Text] + { cOwner :: p :- Text + , cFullName :: p :- Text + , cEmail :: p :- Text + , cLicense :: p :- LicenseName + , cGhcVer :: p :- [GhcVer] + , cCabal :: Decision + , cStack :: Decision + , cGitHub :: Decision + , cTravis :: Decision + , cAppVey :: Decision + , cPrivate :: Decision + , cLib :: Decision + , cExe :: Decision + , cTest :: Decision + , cBench :: Decision + , cPrelude :: Last CustomPrelude + , cExtensions :: [Text] + , cWarnings :: [Text] + , cStylish :: Last Source + , cContributing :: Last Source } 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) +deriving instance + ( GSemigroup (p :- Text) + , GSemigroup (p :- LicenseName) + , GSemigroup (p :- [GhcVer]) + ) => GSemigroup (ConfigP p) +deriving instance + ( GMonoid (p :- Text) + , GMonoid (p :- LicenseName) + , GMonoid (p :- [GhcVer]) + ) => GMonoid (ConfigP p) +deriving instance + ( Eq (p :- Text) + , Eq (p :- LicenseName) + , Eq (p :- [GhcVer]) + ) => Eq (ConfigP p) +deriving instance + ( Show (p :- Text) + , Show (p :- LicenseName) + , Show (p :- [GhcVer]) + ) => Show (ConfigP p) infixl 3 :- type family phase :- field where @@ -91,7 +113,7 @@ { cOwner = Last (Just "kowainik") , cFullName = Last (Just "Kowainik") , cEmail = Last (Just "xrom.xkov@gmail.com") - , cLicense = Last (Just $ License "MIT") + , cLicense = Last (Just MIT) , cGhcVer = Last (Just []) , cCabal = Idk , cStack = Idk @@ -99,13 +121,15 @@ , cTravis = Idk , cAppVey = Idk , cPrivate = Idk - , cScript = Idk , cLib = Idk , cExe = Idk , cTest = Idk , cBench = Idk , cPrelude = Last Nothing , cExtensions = [] + , cWarnings = [] + , cStylish = Last Nothing + , cContributing = Last Nothing } -- | Identifies how to read 'Config' data from the @.toml@ file. @@ -122,31 +146,45 @@ <*> decision "travis" .= cTravis <*> decision "appveyor" .= cAppVey <*> decision "private" .= cPrivate - <*> decision "bscript" .= cScript <*> decision "lib" .= cLib <*> decision "exe" .= cExe <*> decision "test" .= cTest <*> decision "bench" .= cBench <*> lastT (Toml.table preludeT) "prelude" .= cPrelude - <*> extensions "extensions" .= cExtensions + <*> textArr "extensions" .= cExtensions + <*> textArr "warnings" .= cWarnings + <*> wrapLastT (maybeSourceT "stylish") .= cStylish + <*> wrapLastT (maybeSourceT "contributing") .= cContributing where + wrapLastT :: BiToml (Maybe a) -> BiToml (Last a) + wrapLastT = Toml.dimap getLast Last + + maybeSourceT :: Key -> BiToml (Maybe Source) + maybeSourceT key = dimaybeT (sourceT key) + + dimaybeT :: BiToml a -> BiToml (Maybe a) + dimaybeT bi = Bijection + { biRead = optional (biRead bi) + , biWrite = traverse (biWrite bi) + } + lastT :: (Key -> BiToml a) -> Key -> BiToml (Last a) - lastT f = dimap getLast Last . Toml.maybeT f + lastT = Toml.wrapper . Toml.maybeT - _GhcVer :: Prism AnyValue GhcVer - _GhcVer = Prism - { preview = \(AnyValue t) -> Toml.matchText t >>= parseGhcVer - , review = AnyValue . Toml.Text . showGhcVer + _GhcVer :: BiMap AnyValue GhcVer + _GhcVer = BiMap + { forward = \(AnyValue t) -> Toml.matchText t >>= parseGhcVer + , backward = Just . AnyValue . Toml.Text . showGhcVer } ghcVerArr :: Key -> BiToml [GhcVer] ghcVerArr = Toml.arrayOf _GhcVer - license :: Key -> BiToml License - license = dimap unLicense License . Toml.text + license :: Key -> BiToml LicenseName + license = Toml.mdimap show parseLicenseName . Toml.text - extensions :: Key -> BiToml [Text] - extensions = dimap Just maybeToMonoid . Toml.maybeT (Toml.arrayOf Toml._Text) + textArr :: Key -> BiToml [Text] + textArr = dimap Just maybeToMonoid . Toml.maybeT (Toml.arrayOf Toml._Text) decision :: Key -> BiToml Decision decision = dimap fromDecision toDecision . Toml.maybeT Toml.bool @@ -182,13 +220,15 @@ <*> pure cTravis <*> pure cAppVey <*> pure cPrivate - <*> pure cScript <*> pure cLib <*> pure cExe <*> pure cTest <*> pure cBench <*> pure cPrelude <*> pure cExtensions + <*> pure cWarnings + <*> pure cStylish + <*> pure cContributing where fin name = maybe (Failure ["Missing field: " <> name]) Success . getLast diff --git a/src/Summoner/Decision.hs b/src/Summoner/Decision.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Decision.hs @@ -0,0 +1,41 @@ +-- | Decision data type. + +module Summoner.Decision + ( Decision (..) + , decisionToBool + ) where + +import Relude + +import Generics.Deriving.Monoid (GMonoid (..)) +import Generics.Deriving.Semigroup (GSemigroup (..)) + +import Summoner.Question (chooseYesNoBool, falseMessage, trueMessage) + + +-- | Used for detecting the user decision during CLI input. +data Decision = Idk | Nop | Yes + 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 = (<>) + +decisionToBool :: Decision -> Text -> IO Bool +decisionToBool decision target = case decision of + Yes -> trueMessage target + Nop -> falseMessage target + Idk -> chooseYesNoBool target diff --git a/src/Summoner/Default.hs b/src/Summoner/Default.hs --- a/src/Summoner/Default.hs +++ b/src/Summoner/Default.hs @@ -14,14 +14,15 @@ import System.Directory (getHomeDirectory) import System.FilePath (()) -import Summoner.ProjectData (GhcVer (Ghc843)) +import Summoner.GhcVer (GhcVer) ---------------------------------------------------------------------------- -- Default Settings ---------------------------------------------------------------------------- +-- | Default GHC version is the latest available. defaultGHC :: GhcVer -defaultGHC = Ghc843 +defaultGHC = maxBound defaultTomlFile :: String defaultTomlFile = ".summoner.toml" diff --git a/src/Summoner/GhcVer.hs b/src/Summoner/GhcVer.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/GhcVer.hs @@ -0,0 +1,49 @@ +module Summoner.GhcVer + ( GhcVer (..) + , showGhcVer + , parseGhcVer + , latestLts + , baseVer + ) where + +import Relude +import Relude.Extra.Enum (inverseMap) + +-- | Represents some selected set of GHC versions. +data GhcVer + = Ghc7103 + | Ghc801 + | Ghc802 + | Ghc822 + | Ghc843 + deriving (Eq, Ord, Show, Enum, Bounded) + +-- | Converts 'GhcVer' into dot-separated string. +showGhcVer :: GhcVer -> Text +showGhcVer = \case + Ghc7103 -> "7.10.3" + Ghc801 -> "8.0.1" + Ghc802 -> "8.0.2" + Ghc822 -> "8.2.2" + Ghc843 -> "8.4.3" + +parseGhcVer :: Text -> Maybe GhcVer +parseGhcVer = inverseMap showGhcVer + +-- | Returns latest known LTS resolver for all GHC versions except default one. +latestLts :: GhcVer -> Text +latestLts = \case + Ghc7103 -> "6.35" + Ghc801 -> "7.24" + Ghc802 -> "9.21" + Ghc822 -> "11.22" + Ghc843 -> "12.7" + +-- | Returns base version by 'GhcVer'. +baseVer :: GhcVer -> Text +baseVer = \case + Ghc7103 -> "4.8.0.2" + Ghc801 -> "4.9.0.0" + Ghc802 -> "4.9.1.0" + Ghc822 -> "4.10.1.0" + Ghc843 -> "4.11.1.0" diff --git a/src/Summoner/License.hs b/src/Summoner/License.hs --- a/src/Summoner/License.hs +++ b/src/Summoner/License.hs @@ -1,51 +1,88 @@ module Summoner.License - ( License (..) + ( LicenseName(..) + , License(..) , customizeLicense - , licenseNames , githubLicenseQueryNames + , parseLicenseName + , fetchLicense ) where import Relude +import Relude.Extra.Enum (inverseMap) -import Data.Aeson (FromJSON (..), withObject, (.:)) +import Data.Aeson (FromJSON (..), decodeStrict, withObject, (.:)) +import Data.ByteString.Char8 (pack) +import System.Process (readProcess) import qualified Data.Text as T +import qualified Text.Show as TS ---------------------------------------------------------------------------- -- License ---------------------------------------------------------------------------- -licenseNames :: [License] -licenseNames = map fst githubLicenseQueryNames +data LicenseName + = MIT + | BSD2 + | BSD3 + | GPL2 + | GPL3 + | LGPL21 + | LGPL3 + | AGPL3 + | Apache20 + | MPL20 + deriving (Eq, Ord, Enum, Bounded, Generic) -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") - ] +instance Show LicenseName where + show MIT = "MIT" + show BSD2 = "BSD2" + show BSD3 = "BSD3" + show GPL2 = "GPL-2" + show GPL3 = "GPL-3" + show LGPL21 = "LGPL-2.1" + show LGPL3 = "LGPL-3" + show AGPL3 = "AGPL-3" + show Apache20 = "Apache-2.0" + show MPL20 = "MPL-2.0" newtype License = License { unLicense :: Text } - deriving (IsString, Eq, Ord, Show) + deriving (IsString, Show, Generic) 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 +githubLicenseQueryNames :: LicenseName -> Text +githubLicenseQueryNames = \case + MIT -> "mit" + BSD2 -> "bsd-2-clause" + BSD3 -> "bsd-3-clause" + GPL2 -> "gpl-2.0" + GPL3 -> "gpl-3.0" + LGPL21 -> "lgpl-2.1" + LGPL3 -> "lgpl-3.0" + AGPL3 -> "agpl-3.0" + Apache20 -> "apache-2.0" + MPL20 -> "mpl-2.0" + +parseLicenseName :: Text -> Maybe LicenseName +parseLicenseName = inverseMap show + +customizeLicense :: LicenseName -> License -> Text -> Text -> License +customizeLicense l license@(License licenseText) nm year + | l `elem` [MIT, BSD2, BSD3] = License updateLicenseText + | otherwise = license where updateLicenseText = - let (beforeY, withY) = T.span (/= '[') t - afterY = T.tail $ T.dropWhile (/= ']') withY + let (beforeY, withY) = T.span (/= '[') licenseText + afterY = T.tail $ T.dropWhile (/= ']') withY (beforeN, withN) = T.span (/= '[') afterY - afterN = T.tail $ T.dropWhile (/= ']') withN - in beforeY <> year <> beforeN <> nm <> afterN + afterN = T.tail $ T.dropWhile (/= ']') withN + in beforeY <> year <> beforeN <> nm <> afterN + +fetchLicense :: LicenseName -> IO License +fetchLicense name = do + let licenseLink = "https://api.github.com/licenses/" <> githubLicenseQueryNames name + licenseJson <- readProcess + "curl" [ toString licenseLink, "-H", "Accept: application/vnd.github.drax-preview+json"] "" + pure $ fromMaybe (error "Broken predefined license list") (decodeStrict $ pack licenseJson) diff --git a/src/Summoner/Process.hs b/src/Summoner/Process.hs --- a/src/Summoner/Process.hs +++ b/src/Summoner/Process.hs @@ -11,8 +11,8 @@ import Relude import Control.Exception (catch, displayException) -import System.Directory (removeFile, setCurrentDirectory) -import System.Process (callProcess) +import System.Directory (removeFile) +import System.Process (callCommand, showCommandForUser) import Summoner.Ansi (errorMessage) @@ -22,8 +22,10 @@ -- 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) + fromString cmd args = do + let cmdStr = showCommandForUser cmd (map toString args) + putStrLn $ "⚙ " ++ cmdStr + callCommand cmdStr -- Delete file, but just print a message if delete fails and continue instead of raising an error. deleteFile :: FilePath -> IO () diff --git a/src/Summoner/Project.hs b/src/Summoner/Project.hs --- a/src/Summoner/Project.hs +++ b/src/Summoner/Project.hs @@ -7,35 +7,26 @@ ) where import Relude +import Relude.Extra.Enum (universe) -import Data.Aeson (decodeStrict) -import Data.ByteString.Char8 (pack) import NeatInterpolation (text) -import System.Info (os) -import System.Process (readProcess) +import System.Directory (setCurrentDirectory) import Summoner.Ansi (errorMessage, infoMessage, successMessage) import Summoner.Config (Config, ConfigP (..)) +import Summoner.Decision (Decision (..), decisionToBool) import Summoner.Default (currentYear, defaultGHC) -import Summoner.License (License (..), customizeLicense, githubLicenseQueryNames, licenseNames) +import Summoner.GhcVer (parseGhcVer, showGhcVer) +import Summoner.License (customizeLicense, fetchLicense, parseLicenseName) import Summoner.Process () -import Summoner.ProjectData (CustomPrelude (..), Decision (..), ProjectData (..), parseGhcVer, - showGhcVer, supportedGhcVers) -import Summoner.Question (checkUniqueName, choose, chooseYesNo, chooseYesNoBool, falseMessage, - query, queryDef, queryManyRepeatOnFail, targetMessageWithText, - trueMessage) -import Summoner.Template (createStackTemplate) +import Summoner.ProjectData (CustomPrelude (..), ProjectData (..)) +import Summoner.Question (checkUniqueName, choose, chooseYesNo, falseMessage, query, queryDef, + queryManyRepeatOnFail, targetMessageWithText, trueMessage) +import Summoner.Source (fetchSource) +import Summoner.Template (createProjectTemplate) import Summoner.Text (intercalateMap, packageToModule) import Summoner.Tree (showTree, traverseTree) -import qualified Relude.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 @@ -49,31 +40,18 @@ email <- queryDef "Maintainer e-mail: " cEmail putText categoryText category <- query "Category: " - license <- choose "License: " $ map unLicense $ ordNub (cLicense : licenseNames) + licenseName <- choose parseLicenseName "License: " $ ordNub (cLicense : universe) -- 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" - ] - "" + fetchedLicense <- fetchLicense licenseName 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" + let licenseText = customizeLicense licenseName fetchedLicense nm year -- Library/Executable/Tests/Benchmarks flags github <- decisionToBool cGitHub "GitHub integration" travis <- ifGithub github "Travis CI integration" cTravis appVey <- ifGithub (stack && github) "AppVeyor CI integration" cAppVey privat <- ifGithub github "private repository" cPrivate - script <- decisionToBool cScript "build script" isLib <- decisionToBool cLib "library target" isExe <- let target = "executable target" in if isLib @@ -88,23 +66,31 @@ let extensions = cExtensions + let warnings = cWarnings + 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 + infoMessage $ "Supported by 'summoner' GHCs: " <> intercalateMap " " showGhcVer universe queryManyRepeatOnFail parseGhcVer vers -> do putTextLn $ "Also these GHC versions will be added: " <> intercalateMap " " showGhcVer vers pure vers + stylish <- case getLast cStylish of + Nothing -> pure Nothing + Just s -> fetchSource s + + contributing <- case getLast cContributing of + Nothing -> pure Nothing + Just s -> fetchSource s + -- 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 @@ -116,14 +102,11 @@ createProjectDirectory :: ProjectData -> IO () createProjectDirectory projectData@ProjectData{..} = do - let tree = createStackTemplate projectData + let tree = createProjectTemplate 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"]) + setCurrentDirectory (toString repo) doGithubCommands :: ProjectData -> Bool -> IO () doGithubCommands ProjectData{..} private = do diff --git a/src/Summoner/ProjectData.hs b/src/Summoner/ProjectData.hs --- a/src/Summoner/ProjectData.hs +++ b/src/Summoner/ProjectData.hs @@ -2,27 +2,20 @@ module Summoner.ProjectData ( ProjectData (..) - , GhcVer (..) - , supportedGhcVers - , parseGhcVer - , showGhcVer - , latestLts - , baseNopreludeVer - - , Decision (..) , CustomPrelude (..) - - , Answer (..) - , yesOrNo ) where import Relude -import Generics.Deriving.Monoid (GMonoid (..)) -import Generics.Deriving.Semigroup (GSemigroup (..)) +import Summoner.GhcVer (GhcVer) +import Summoner.License (License, LicenseName) -import qualified Data.Text as T +data CustomPrelude = Prelude + { cpPackage :: Text + , cpModule :: Text + } deriving (Show, Eq) + -- | Data needed for project creation. data ProjectData = ProjectData { repo :: Text -- ^ repository name @@ -32,12 +25,11 @@ , email :: Text -- ^ e-mail , year :: Text -- ^ year , category :: Text -- ^ project category - , license :: Text -- ^ type of license - , licenseText :: Text -- ^ license text + , licenseName :: LicenseName -- ^ type of license + , licenseText :: License -- ^ 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 @@ -46,85 +38,9 @@ , base :: Text -- ^ Base library to use , prelude :: Maybe CustomPrelude -- ^ custom prelude to be used , extensions :: [Text] -- ^ default extensions + , warnings :: [Text] -- ^ default warnings , cabal :: Bool , stack :: Bool - } 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 - | Ghc843 - 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" -showGhcVer Ghc843 = "8.4.3" - --- | 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 "8.4.3" = Just Ghc843 -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.17" -latestLts Ghc843 = "12.2" - -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" -baseNopreludeVer Ghc843 = "4.11.1.0" - -data CustomPrelude = Prelude - { cpPackage :: Text - , cpModule :: Text + , stylish :: Maybe Text -- ^ @.stylish-haskell.yaml@ file + , contributing :: Maybe Text -- ^ @CONTRIBUTING.md@ file } 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 --- a/src/Summoner/Question.hs +++ b/src/Summoner/Question.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} -- | This module contains function to proper questioning in terminal. @@ -26,7 +27,6 @@ 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 @@ -34,6 +34,19 @@ import qualified Relude.Unsafe as Unsafe ---------------------------------------------------------------------------- +-- Yes/No +---------------------------------------------------------------------------- + +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 + +---------------------------------------------------------------------------- -- IO Questioning ---------------------------------------------------------------------------- @@ -45,15 +58,15 @@ putTextLn $ "/" <> restSlash printQuestion question [] = T.putStrLn question -choose :: Text -> [Text] -> IO Text -choose question choices = do - printQuestion question choices +choose :: Show a => (Text -> Maybe a) -> Text -> [a] -> IO a +choose parser question choices = do + let showChoices = map show choices + printQuestion question showChoices 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 + if T.null answer + then pure (Unsafe.head choices) + else whenNothing (parser answer) + (errorMessage "This wasn't a valid choice." >> choose parser question choices) chooseYesNo :: Text -- ^ target -> IO a -- ^ action for 'Y' answer @@ -78,8 +91,8 @@ targetMessageWithText :: Bool -> Text -> Text -> IO Bool targetMessageWithText result target text = do let (color, actionResult) = if result - then (Green, " will be " <> text) - else (Cyan, " won't be" <> text) + then (Green, " will be " <> text) + else (Cyan, " won't be " <> text) beautyPrint [italic, bold, setColor color] $ " " <> headToUpper target beautyPrint [setColor color] actionResult diff --git a/src/Summoner/Source.hs b/src/Summoner/Source.hs new file mode 100644 --- /dev/null +++ b/src/Summoner/Source.hs @@ -0,0 +1,53 @@ +module Summoner.Source + ( Source (..) + , sourceT + , fetchSource + ) where + +import Relude + +import Control.Arrow ((>>>)) +import Control.Exception (catch) +import System.Process (readProcess) +import Toml (BiMap, BiToml, Key) + +import Summoner.Ansi (errorMessage) + +import qualified Toml + +data Source + -- | URL link to the source file. + = Url Text + -- | File path to the local source file. + | File FilePath + deriving (Show, Eq) + +sourceT :: Key -> BiToml Source +sourceT nm = Toml.match (Toml._Text >>> _Url) (nm <> "url") + <|> Toml.match (Toml._String >>> _File) (nm <> "file") + where + _Url :: BiMap Text Source + _Url = Toml.invert $ Toml.prism (source Just (const Nothing)) Url + + _File :: BiMap FilePath Source + _File = Toml.invert $ Toml.prism (source (const Nothing) Just) File + + source :: (Text -> c) -> (FilePath -> c) -> Source -> c + source f _ (Url x) = f x + source _ f (File x) = f x + +fetchSource :: Source -> IO (Maybe Text) +fetchSource = \case + File path -> catch (Just <$> readFile path) (fileError path) + Url url -> catch (fetchUrl url) (urlError url) + where + fileError :: FilePath -> SomeException -> IO (Maybe Text) + fileError path _ = errorMessage ("Couldn't read file: " <> toText path) + >> pure Nothing + + urlError :: Text -> SomeException -> IO (Maybe Text) + urlError url _ = errorMessage ("Couldn't get to link: " <> url) + >> pure Nothing + + fetchUrl :: Text -> IO (Maybe Text) + fetchUrl url = Just . toText <$> readProcess "curl" [toString url] "" diff --git a/src/Summoner/Template.hs b/src/Summoner/Template.hs --- a/src/Summoner/Template.hs +++ b/src/Summoner/Template.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ViewPatterns #-} -- | This module contains functions for stack template creation. module Summoner.Template - ( createStackTemplate + ( createProjectTemplate ) where import Relude @@ -14,46 +13,52 @@ import NeatInterpolation (text) import Summoner.Default (defaultGHC, endLine) -import Summoner.ProjectData (CustomPrelude (..), GhcVer (..), ProjectData (..), baseNopreludeVer, - latestLts, showGhcVer) +import Summoner.GhcVer (GhcVer (..), baseVer, latestLts, showGhcVer) +import Summoner.License (License (..)) +import Summoner.ProjectData (CustomPrelude (..), ProjectData (..)) import Summoner.Text (intercalateMap, packageToModule) import Summoner.Tree (TreeFs (..)) import qualified Data.Text as T ---------------------------------------------------------------------------- --- Stack File Creation +-- Project Directory Creation ---------------------------------------------------------------------------- -emptyIfNot :: Monoid m => Bool -> m -> m -emptyIfNot p val = if p then val else mempty +memptyIfFalse :: Monoid m => Bool -> m -> m +memptyIfFalse p val = if p then val else mempty --- | Creating template file to use in `stack new` command -createStackTemplate :: ProjectData -> TreeFs -createStackTemplate ProjectData{..} = Dir (toString repo) $ +-- | Creating tree structure of the project. +createProjectTemplate :: ProjectData -> TreeFs +createProjectTemplate ProjectData{..} = Dir (toString repo) $ [ File (toString repo <> ".cabal") ( createCabalTop - <> emptyIfNot github createCabalGit - <> emptyIfNot isLib createCabalLib - <> emptyIfNot isExe + <> memptyIfFalse github createCabalGit + <> memptyIfFalse isLib createCabalLib + <> memptyIfFalse isExe ( createCabalExe - $ emptyIfNot isLib $ ", " <> repo ) - <> emptyIfNot test createCabalTest - <> emptyIfNot bench + $ memptyIfFalse isLib $ ", " <> repo ) + <> memptyIfFalse test + ( createCabalTest + $ memptyIfFalse isLib $ ", " <> repo ) + <> memptyIfFalse bench ( createCabalBenchmark - $ emptyIfNot isLib $ ", " <> repo ) + $ memptyIfFalse isLib $ ", " <> repo ) ) , File "README.md" readme , File "CHANGELOG.md" changelog - , File "LICENSE" licenseText + , File "LICENSE" $ unLicense licenseText ] ++ createCabalFiles - ++ emptyIfNot stack (createStackYamls testedVersions) + ++ memptyIfFalse stack (createStackYamls testedVersions) ++ [File ".gitignore" gitignore | github] ++ [File ".travis.yml" travisYml | travis] ++ [File "appveyor.yml" appVeyorYml | appVey] - ++ [File "b" scriptSh | script] + ++ maybe [] (\x -> [File ".stylish-haskell.yaml" x]) stylish + ++ maybe [] (\x -> [File "CONTRIBUTING.md" x]) contributing where + license = show licenseName + -- Creates module name from the name of the project libModuleName :: Text libModuleName = packageToModule repo @@ -72,12 +77,13 @@ createCabalTop :: Text createCabalTop = [text| + cabal-version: 1.24 name: $repo version: 0.0.0 description: $description synopsis: $description - homepage: https://github.com/${owner}/${repo} - bug-reports: https://github.com/${owner}/${repo}/issues + $githubHomepage + $githubBugReports license: $license license-file: LICENSE author: $nm @@ -87,11 +93,14 @@ build-type: Simple extra-doc-files: README.md , CHANGELOG.md - cabal-version: 1.24 tested-with: $testedGhcs $endLine |] + where + githubHomepage :: Text = memptyIfFalse github $ "homepage: https://github.com/" <> owner <> "/" <> repo + githubBugReports :: Text = memptyIfFalse github $ "bug-reports: https://github.com/" <> owner <> "/" <> repo <> "/issues" + testedGhcs :: Text testedGhcs = intercalateMap ", " (mappend "GHC == " . showGhcVer) testedVersions @@ -109,6 +118,35 @@ $endLine |] + ghcOptions :: Text + ghcOptions = case warnings of + [] -> defaultWarnings + xs -> T.intercalate "\n" xs + + defaultWarnings :: Text + defaultWarnings = + [text| + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + $versionWarnings + |] + + versionWarnings :: Text + versionWarnings + = memptyIfFalse (testedVersions `hasLeast` Ghc801) + "-Wredundant-constraints\n" + <> memptyIfFalse (testedVersions `hasLeast` Ghc822) + "-fhide-source-paths\n" + <> memptyIfFalse (testedVersions `hasLeast` Ghc843) + [text| + -Wmissing-export-lists + -Wpartial-fields + |] + where + hasLeast list el = all (>= el) list + createCabalLib :: Text createCabalLib = [text| @@ -117,6 +155,7 @@ exposed-modules: $libModuleName $preludeMod ghc-options: -Wall + $ghcOptions build-depends: $base $customPreludePack default-language: Haskell2010 @@ -130,7 +169,11 @@ executable $repo hs-source-dirs: app main-is: Main.hs - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall + -threaded + -rtsopts + -with-rtsopts=-N + $ghcOptions build-depends: $base $r $customPreludePack @@ -139,17 +182,21 @@ $endLine |] - createCabalTest :: Text - createCabalTest = + createCabalTest :: Text -> Text + createCabalTest r = [text| test-suite ${repo}-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs + ghc-options: -Wall + -threaded + -rtsopts + -with-rtsopts=-N + $ghcOptions build-depends: $base - , $repo + $r $customPreludePack - ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 $defaultExtensions $endLine @@ -160,14 +207,18 @@ [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 + ghc-options: -Wall + -threaded + -rtsopts + -with-rtsopts=-N + $ghcOptions build-depends: $base , gauge - $customPreludePack $r + $customPreludePack + default-language: Haskell2010 $defaultExtensions $endLine |] @@ -220,8 +271,6 @@ createOnlyExe :: Text createOnlyExe = [text| - module Main where - main :: IO () main = putStrLn ("Hello, world!" :: String) $endLine @@ -230,8 +279,6 @@ createExe :: Text createExe = [text| - module Main where - import $libModuleName (someFunc) main :: IO () @@ -251,42 +298,61 @@ -- create README template readme :: Text - readme = - [text| - # $repo - - [![Hackage]($hackageShield)]($hackageLink) - [![$license license](${licenseShield})](${licenseLink}) - $travisBadge - $appVeyorBadge - - $description - $endLine - |] + readme = T.intercalate "\n" $ + [ "# " <> repo + , "" + , hackage + , licenseBadge + ] + ++ [stackLtsBadge | stack] + ++ [stackNightlyBadge | stack] + ++ [travisBadge | travis] + ++ [appVeyorBadge | appVey] + ++ ["" + , description + ] where hackageShield :: Text = - "https://img.shields.io/hackage/v/" <> repo <> ".svg" + "https://img.shields.io/hackage/v/" <> repo <> ".svg" hackageLink :: Text = - "https://hackage.haskell.org/package/" <> repo + "https://hackage.haskell.org/package/" <> repo + hackage :: Text = makeBadge "Hackage" hackageShield hackageLink + licenseShield :: Text = + "https://img.shields.io/badge/license-" <> T.replace "-" "--" license <> "-blue.svg" + licenseBadge :: Text = + makeBadge (license <> " license") licenseShield "LICENSE" + + stackShieldLts :: Text = + "http://stackage.org/package/" <> repo <> "/badge/lts" + stackLinkLts :: Text = + "http://stackage.org/lts/package/" <> repo + + stackShieldNightly :: Text = + "http://stackage.org/package/" <> repo <> "/badge/nightly" + stackLinkNightly :: Text = + "http://stackage.org/nightly/package/" <> repo + stackLtsBadge :: Text = + makeBadge "Stackage Lts" stackShieldLts stackLinkLts + stackNightlyBadge :: Text = + makeBadge "Stackage Nightly" stackShieldNightly stackLinkNightly + travisShield :: Text = - "https://secure.travis-ci.org/" <> owner <> "/" <> repo <> ".svg" + "https://secure.travis-ci.org/" <> owner <> "/" <> repo <> ".svg" travisLink :: Text = - "https://travis-ci.org/" <> owner <> "/" <> repo - travisBadge :: Text = emptyIfNot travis - [text|[![Build status](${travisShield})](${travisLink})|] + "https://travis-ci.org/" <> owner <> "/" <> repo + travisBadge :: Text = + makeBadge "Build status" travisShield travisLink appVeyorShield :: Text = - "https://ci.appveyor.com/api/projects/status/github/" <> owner <> "/" <> repo <> "?branch=master&svg=true" + "https://ci.appveyor.com/api/projects/status/github/" <> owner <> "/" <> repo <> "?branch=master&svg=true" appVeyorLink :: Text = - "https://ci.appveyor.com/project/" <> owner <> "/" <> repo - appVeyorBadge :: Text = emptyIfNot appVey - [text|[![Windows build status](${appVeyorShield})](${appVeyorLink})|] + "https://ci.appveyor.com/project/" <> owner <> "/" <> repo + appVeyorBadge :: Text = + makeBadge "Windows build status" appVeyorShield appVeyorLink - licenseShield :: Text = - "https://img.shields.io/badge/license-" <> T.replace "-" "--" license <> "-blue.svg" - licenseLink :: Text = - "https://github.com/" <> owner <> "/" <> repo <> "/blob/master/LICENSE" + makeBadge :: Text -> Text -> Text -> Text + makeBadge title shield link = "[![" <> title <> "](" <> shield <> ")](" <> link <> ")" -- create .gitignore template gitignore :: Text @@ -352,28 +418,31 @@ changelog :: Text changelog = [text| - Change log - ========== + # Change log - $repo uses [PVP Versioning][1]. - The change log is available [on GitHub][2]. + `$repo` uses [PVP Versioning][1]. + $githubLine 0.0.0 ===== + * Initially created. [1]: https://pvp.haskell.org - [2]: https://github.com/${owner}/${repo}/releases - $endLine + $githubFootNote |] + where + githubLine :: Text = memptyIfFalse github $ "The change log is available [on GitHub][2]." + githubFootNote :: Text = memptyIfFalse github $ + "[2]: https://github.com/" <> owner <> "/" <> repo <> "/releases" -- create travis.yml template travisYml :: Text travisYml = - let travisStackMtr = emptyIfNot stack $ + let travisStackMtr = memptyIfFalse stack $ T.concat (map travisStackMatrixItem $ delete defaultGHC testedVersions) <> travisStackMatrixDefaultItem - travisCabalMtr = emptyIfNot cabal $ + travisCabalMtr = memptyIfFalse cabal $ T.concat $ map travisCabalMatrixItem testedVersions installAndScript = if cabal @@ -381,6 +450,12 @@ then installScriptBoth else installScriptCabal else installScriptStack + travisCabalCache = memptyIfFalse cabal "- \"$HOME/.cabal\"" + travisStackCache = memptyIfFalse stack + [text| + - "$$HOME/.stack" + - "$$TRAVIS_BUILD_DIR/.stack-work" + |] in [text| sudo: true @@ -391,8 +466,8 @@ cache: directories: - - "$$HOME/.stack" - - "$$TRAVIS_BUILD_DIR/.stack-work" + $travisCabalCache + $travisStackCache matrix: include: @@ -518,10 +593,10 @@ createStackYaml ghcV = let ver = case ghcV of Ghc843 -> "" _ -> "-" <> showGhcVer ghcV - in stackYaml ver (latestLts ghcV) (baseNopreludeVer ghcV) + in stackYaml ver (latestLts ghcV) (baseVer ghcV) where stackYaml :: Text -> Text -> Text -> TreeFs - stackYaml ghc lts baseVer = File (toString $ "stack" <> ghc <> ".yaml") + stackYaml ghc lts baseV = File (toString $ "stack" <> ghc <> ".yaml") [text| resolver: lts-${lts} @@ -534,7 +609,7 @@ extraDeps :: Text extraDeps = case prelude of Nothing -> "" - Just _ -> "extra-deps: [base-noprelude-" <> baseVer <> "]" + Just _ -> "extra-deps: [base-noprelude-" <> baseV <> "]" ghcOpts :: Text ghcOpts = if ghcV <= Ghc802 then "" @@ -568,106 +643,4 @@ # 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/Tree.hs b/src/Summoner/Tree.hs --- a/src/Summoner/Tree.hs +++ b/src/Summoner/Tree.hs @@ -10,6 +10,8 @@ import System.Directory (createDirectoryIfMissing, withCurrentDirectory) +import Summoner.Ansi (boldCode, resetCode) + -- | Describes simple structure of filesystem tree. data TreeFs -- | Name of directory (relative) and its containing entries @@ -35,7 +37,12 @@ nodeRep : showChildren trees (leader <> extension) where nodeRep :: Text - nodeRep = leader <> arm <> tie <> toText fp + nodeRep = leader <> arm <> tie <> boldDir (fp <> "/") + where + boldDir str = toText + $ boldCode + <> str + <> resetCode extension :: Text extension = case arm of "" -> ""; "└" -> " "; _ -> "│ " diff --git a/summoner.cabal b/summoner.cabal --- a/summoner.cabal +++ b/summoner.cabal @@ -1,5 +1,5 @@ name: summoner -version: 1.0.6 +version: 1.1.0 synopsis: Tool for creating completely configured production Haskell projects. description: Tool for creating completely configured production Haskell projects. See README.md for details. @@ -29,12 +29,15 @@ Summoner.Ansi Summoner.CLI Summoner.Config + Summoner.Decision Summoner.Default + Summoner.GhcVer Summoner.License Summoner.Process Summoner.Project Summoner.ProjectData Summoner.Question + Summoner.Source Summoner.Template Summoner.Text Summoner.Tree @@ -44,20 +47,27 @@ autogen-modules: Paths_summoner ghc-options: -Wall - build-depends: base >= 4.9 && < 5 + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths + build-depends: base >= 4.10 && < 5 , aeson , ansi-terminal , bytestring , directory , filepath , generic-deriving + , gitrev , neat-interpolation , optparse-applicative , process , text , time - , tomland ^>= 0.3 - , relude + , tomland ^>= 0.4.0 + , relude ^>= 0.2.0 default-extensions: DeriveGeneric GeneralizedNewtypeDeriving @@ -66,13 +76,24 @@ NoImplicitPrelude OverloadedStrings RecordWildCards + ScopedTypeVariables + TypeApplications default-language: Haskell2010 executable summon hs-source-dirs: app main-is: Main.hs - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall + -threaded + -rtsopts + -with-rtsopts=-N + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths build-depends: base , relude , summoner @@ -84,6 +105,7 @@ main-is: Spec.hs other-modules: Test.DecisionSpec + Test.TomlSpec build-tool-depends: tasty-discover:tasty-discover build-depends: base @@ -91,8 +113,18 @@ , relude , tasty , tasty-hedgehog + , tomland , summoner default-extensions: NoImplicitPrelude - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall + -threaded + -rtsopts + -with-rtsopts=-N + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths default-language: Haskell2010 diff --git a/test/Test/DecisionSpec.hs b/test/Test/DecisionSpec.hs --- a/test/Test/DecisionSpec.hs +++ b/test/Test/DecisionSpec.hs @@ -6,7 +6,7 @@ import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testProperty) -import Summoner.ProjectData (Decision) +import Summoner.Decision (Decision) import qualified Hedgehog.Gen as Gen diff --git a/test/Test/TomlSpec.hs b/test/Test/TomlSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/TomlSpec.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE RecordWildCards #-} + +module Test.TomlSpec where + +import Relude +import Relude.Extra.Enum (universe) + +import Hedgehog (MonadGen, forAll, property, tripping) +import Test.Tasty (TestTree) +import Test.Tasty.Hedgehog (testProperty) +import Toml.Bi.Code (decode, encode) + +import Summoner.Config (ConfigP (..), PartialConfig, configT) +import Summoner.GhcVer (GhcVer) +import Summoner.License (LicenseName) +import Summoner.ProjectData (CustomPrelude (..)) +import Summoner.Source (Source (..)) +import Test.DecisionSpec (genDecision) + +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +genText :: MonadGen m => m Text +genText = Gen.text + (Range.constant 0 10) + (Gen.frequency [ (1, Gen.element ['.','-']), (10, Gen.alphaNum) ]) + +genTextArr :: MonadGen m => m [Text] +genTextArr = Gen.list (Range.constant 0 10) genText + +genGhcVerArr :: MonadGen m => m [GhcVer] +genGhcVerArr = Gen.list (Range.constant 0 10) Gen.enumBounded + +genCustomPrelude :: MonadGen m => m CustomPrelude +genCustomPrelude = Prelude <$> genText <*> genText + +genLicense :: MonadGen m => m LicenseName +genLicense = Gen.element universe + +genSource :: MonadGen m => m Source +genSource = do + txt <- genText + s <- Gen.element [File . toString, Url] + pure $ s txt + +genPartialConfig :: MonadGen m => m PartialConfig +genPartialConfig = do + cOwner <- Last . Just <$> genText + cFullName <- Last . Just <$> genText + cEmail <- Last . Just <$> genText + cLicense <- Last . Just <$> genLicense + cGhcVer <- Last . Just <$> genGhcVerArr + cCabal <- genDecision + cStack <- genDecision + cGitHub <- genDecision + cTravis <- genDecision + cAppVey <- genDecision + cPrivate <- genDecision + cLib <- genDecision + cExe <- genDecision + cTest <- genDecision + cBench <- genDecision + cPrelude <- Last <$> Gen.maybe genCustomPrelude + cExtensions <- genTextArr + cWarnings <- genTextArr + cStylish <- Last <$> Gen.maybe genSource + cContributing <- Last <$> Gen.maybe genSource + pure Config{..} + +test_Toml :: [TestTree] +test_Toml = pure $ testProperty "decode . encode == id" $ property $ do + configToml <- forAll genPartialConfig + tripping configToml (encode configT) (decode configT)