summoner 1.0.6 → 1.1.0
raw patch · 20 files changed
+940/−534 lines, 20 filesdep +gitrevdep ~basedep ~reludedep ~tomlandsetup-changed
Dependencies added: gitrev
Dependency ranges changed: base, relude, tomland
Files
- CHANGELOG.md +46/−1
- README.md +111/−57
- Setup.hs +0/−2
- src/Summoner/Ansi.hs +11/−1
- src/Summoner/CLI.hs +142/−63
- src/Summoner/Config.hs +79/−39
- src/Summoner/Decision.hs +41/−0
- src/Summoner/Default.hs +3/−2
- src/Summoner/GhcVer.hs +49/−0
- src/Summoner/License.hs +64/−27
- src/Summoner/Process.hs +6/−4
- src/Summoner/Project.hs +26/−43
- src/Summoner/ProjectData.hs +12/−96
- src/Summoner/Question.hs +26/−13
- src/Summoner/Source.hs +53/−0
- src/Summoner/Template.hs +151/−178
- src/Summoner/Tree.hs +8/−1
- summoner.cabal +38/−6
- test/Test/DecisionSpec.hs +1/−1
- test/Test/TomlSpec.hs +73/−0
CHANGELOG.md view
@@ -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 <LICENSE_NAME>` 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.
README.md view
@@ -1,58 +1,71 @@ # 🔮 Summoner + [](http://travis-ci.org/kowainik/summoner) [](https://github.com/kowainik/summoner/blob/master/LICENSE) [](https://hackage.haskell.org/package/summoner) [](http://stackage.org/lts/package/summoner) [](http://stackage.org/nightly/package/summoner)+[](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 -[](https://asciinema.org/a/PCt492vIY7ccuNw3qBJFM9q9G)+[](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/).
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
src/Summoner/Ansi.hs view
@@ -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]
src/Summoner/CLI.hs view
@@ -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|
src/Summoner/Config.hs view
@@ -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
+ src/Summoner/Decision.hs view
@@ -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
src/Summoner/Default.hs view
@@ -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"
+ src/Summoner/GhcVer.hs view
@@ -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"
src/Summoner/License.hs view
@@ -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)
src/Summoner/Process.hs view
@@ -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 ()
src/Summoner/Project.hs view
@@ -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
src/Summoner/ProjectData.hs view
@@ -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
src/Summoner/Question.hs view
@@ -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
+ src/Summoner/Source.hs view
@@ -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] ""
src/Summoner/Template.hs view
@@ -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-- []($hackageLink)- [](${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|[](${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|[](${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 |]
src/Summoner/Tree.hs view
@@ -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 "" -> ""; "└" -> " "; _ -> "│ "
summoner.cabal view
@@ -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
test/Test/DecisionSpec.hs view
@@ -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
+ test/Test/TomlSpec.hs view
@@ -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)