[#333] Use key-value map for extra files (#372)

* Create specified extra files (#366) * Add deprecation messages (#368) * Update documentation
kowainik · Nov 5, 2019 · 27efed3 · 27efed3
1 parent 39f00e6
commit 27efed3
Show file tree

Hide file tree

Showing 20 changed files with 218 additions and 69 deletions.
diff --git a/README.md b/README.md
@@ -361,8 +361,9 @@ Here is the list of the options that can be configured to suit your needs. If op
 | `bench`          | Bool    | Create `benchmark` folder with `Main.hs` file with [`gauge`](https://hackage.haskell.org/package/gauge) library usage example?                                       |
 | `extensions`     | [Text]  | List of the default extensions to add into `default-extensions` section in the `.cabal`.                                                                             |
 | `ghc-options`    | [Text]  | List of the default GHC options to add into `ghc-options` section in the `.cabal`.                                                                                   |
-| `stylish.*`      | Text    | `stylish.file` to provide the absolute file path OR `stylish.url` to download the `.stylish-haskell.yaml` file to use in the project.                                |
-| `contributing.*` | Text    | `contributing.file` to provide the absolute file path OR `contributing.url` download OR `contribuint.link` to link the `CONTRIBUTING.md` file to use in the project. |
+| `stylish.*`      | Text    | **DEPRECATED** `stylish.file` to provide the absolute file path OR `stylish.url` to download the `.stylish-haskell.yaml` file to use in the project.                                |
+| `contributing.*` | Text    | **DEPRECATED** `contributing.file` to provide the absolute file path OR `contributing.url` download OR `contribuint.link` to link the `CONTRIBUTING.md` file to use in the project. |
+| `files`          | Map FilePath Source  | Custom mapping of files to their sources. Represented as a list of inline tables in TOML in a format like `files = [ { path = "foo", url = "https://..." }, ... ]` |
 |`[prelude]`       |         |                                                                                                                                                                      |
 | `package`        | Text    | The package name of the custom prelude you'd like to use in the project (doesn't work without `module` field).                                                       |
 | `module`         | Text    | The module name of the custom prelude you'd like to use in the project (doesn't work without `package` field).                                                       |

diff --git a/cabal.project b/cabal.project
@@ -1,3 +1,8 @@
 packages: summoner-cli/ summoner-tui/
 
-tests: true
+tests: true
+
+source-repository-package
+    type: git
+    location: https://github.com/kowainik/tomland
+    tag: f06fa1c72a4c4cf5dd6fbc988d920f62d1eb30af
diff --git a/stack-nightly.yaml b/stack-nightly.yaml
@@ -1,4 +1,4 @@
-resolver: nightly-2019-10-31
+resolver: nightly-2019-11-04
 
 packages:
   - summoner-cli/
@@ -7,5 +7,7 @@ packages:
 extra-deps:
   - base-noprelude-4.13.0.0
   - brick-0.50
-  - relude-0.6.0.0
   - vty-5.26
+
+  - github: kowainik/tomland
+    commit: f06fa1c72a4c4cf5dd6fbc988d920f62d1eb30af
diff --git a/stack.yaml b/stack.yaml
@@ -6,3 +6,7 @@ packages:
 
 extra-deps:
   - optparse-applicative-0.15.0.0
+  - relude-0.6.0.0
+
+  - github: kowainik/tomland
+    commit: f06fa1c72a4c4cf5dd6fbc988d920f62d1eb30af
diff --git a/summoner-cli/CHANGELOG.md b/summoner-cli/CHANGELOG.md
@@ -34,6 +34,29 @@ The changelog is available [on GitHub][2].
   Build Summoner with GHC-8.8.1.
 * [#337](https://github.com/kowainik/summoner/issues/337):
   Allow `generic-deriving-1.13`.
+* [#333](https://github.com/kowainik/summoner/issues/333):
+  Introduce `files` option in the TOML configuration which allows to specify
+  custom files. Deprecate `stylish` and `contributing` options.
+
+  _Migration guide:_ Instead of
+
+  ```toml
+  stylish.url = "some url"
+  contributing.link = "some link"
+  ```
+
+  specify them like this:
+
+  ```toml
+  files =
+      [ { path = ".stylish-haskell.yaml"
+        , url  = "some url"
+        }
+      , { path = "CONTRIBUTING.md"
+        , link = "some link"
+        }
+      ]
+  ```
 
 ## 1.3.0.1 — Apr 10, 2019
 

diff --git a/summoner-cli/src/Summoner.hs b/summoner-cli/src/Summoner.hs
@@ -9,9 +9,9 @@ import Summoner.CustomPrelude as Summoner
 import Summoner.Default as Summoner
 import Summoner.GhcVer as Summoner
 import Summoner.License as Summoner
-import Summoner.Process as Summoner
 import Summoner.Project as Summoner
 import Summoner.Question as Summoner
 import Summoner.Settings as Summoner
 import Summoner.Template as Summoner
 import Summoner.Text as Summoner
+import Summoner.Tree as Summoner
diff --git a/summoner-cli/src/Summoner/Config.hs b/summoner-cli/src/Summoner/Config.hs
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 {-# LANGUAGE DataKinds            #-}
 {-# LANGUAGE DeriveAnyClass       #-}
 {-# LANGUAGE FlexibleContexts     #-}
@@ -14,23 +16,23 @@ module Summoner.Config
 
        , PartialConfig
        , Config
-       , configT
+       , configCodec
        , defaultConfig
        , finalise
 
        , loadFileConfig
        ) where
 
 import Data.List (lookup)
-import Generics.Deriving.Monoid (GMonoid, gmemptydefault)
-import Generics.Deriving.Semigroup (GSemigroup, gsappenddefault)
+import Generics.Deriving.Monoid (GMonoid (..), gmemptydefault)
+import Generics.Deriving.Semigroup (GSemigroup (..), gsappenddefault)
 import Toml (Key, TomlBiMap, TomlCodec, (.=))
 
 import Summoner.CustomPrelude (CustomPrelude (..), customPreludeT)
 import Summoner.Decision (Decision (..))
 import Summoner.GhcVer (GhcVer (..), parseGhcVer, showGhcVer)
 import Summoner.License (LicenseName (..), parseLicenseName)
-import Summoner.Source (Source, sourceT)
+import Summoner.Source (Source, sourceT, sourceCodec)
 
 import qualified Toml
 
@@ -59,12 +61,13 @@ data ConfigP (p :: Phase) = Config
     , cBench        :: !Decision
     , cPrelude      :: !(Last CustomPrelude)
     , cExtensions   :: ![Text]
-    , cWarnings     :: ![Text]
-    , cGhcOptions   :: ![Text]  -- ^ GHC options to add every stanza
+    , cWarnings     :: ![Text]  -- ^ DEPRECATED: TODO: remove in 1.4.
+    , cGhcOptions   :: ![Text]  -- ^ GHC options to add to each stanza
     , cGitignore    :: ![Text]
-    , cStylish      :: !(Last Source)
-    , cContributing :: !(Last Source)
+    , cStylish      :: !(Last Source)  -- ^ DEPRECATED: source to .stylish-haskell.yaml
+    , cContributing :: !(Last Source)  -- ^ DEPRECATED: source to CONTRIBUTING.md
     , cNoUpload     :: !Any  -- ^ Do not upload to the GitHub (even if enabled)
+    , cFiles        :: !(Map FilePath Source)  -- ^ Custom files
     } deriving stock (Generic)
 
 deriving anyclass instance
@@ -109,6 +112,13 @@ instance Monoid PartialConfig where
     mempty = gmemptydefault
     mappend = (<>)
 
+instance Ord k => GSemigroup (Map k v) where
+    gsappend = (<>)
+
+instance Ord k => GMonoid (Map k v) where
+    gmempty = mempty
+    gmappend = (<>)
+
 -- | Default 'Config' configurations.
 defaultConfig :: PartialConfig
 defaultConfig = Config
@@ -135,11 +145,12 @@ defaultConfig = Config
     , cStylish  = Last Nothing
     , cContributing = Last Nothing
     , cNoUpload = Any False
+    , cFiles = mempty
     }
 
 -- | Identifies how to read 'Config' data from the @.toml@ file.
-configT :: TomlCodec PartialConfig
-configT = Config
+configCodec :: TomlCodec PartialConfig
+configCodec = Config
     <$> lastT Toml.text "owner"       .= cOwner
     <*> lastT Toml.text "fullName"    .= cFullName
     <*> lastT Toml.text "email"       .= cEmail
@@ -163,6 +174,7 @@ configT = Config
     <*> lastT sourceT  "stylish"      .= cStylish
     <*> lastT sourceT  "contributing" .= cContributing
     <*> anyT           "noUpload"     .= cNoUpload
+    <*> filesCodec     "files"        .= cFiles
   where
     lastT :: (Key -> TomlCodec a) -> Key -> TomlCodec (Last a)
     lastT codec = Toml.dimap getLast Last . Toml.dioptional . codec
@@ -200,6 +212,8 @@ configT = Config
     preludeT :: Key -> TomlCodec CustomPrelude
     preludeT = Toml.table customPreludeT
 
+    filesCodec :: Key -> TomlCodec (Map FilePath Source)
+    filesCodec = Toml.map (Toml.string "path") sourceCodec
 
 -- | Make sure that all the required configurations options were specified.
 finalise :: PartialConfig -> Validation [Text] Config
@@ -227,9 +241,11 @@ finalise Config{..} = Config
     <*> pure cStylish
     <*> pure cContributing
     <*> pure cNoUpload
+    <*> pure cFiles
   where
+    fin :: Text -> Last a -> Validation [Text] a
     fin name = maybe (Failure ["Missing field: " <> name]) Success . getLast
 
 -- | Read configuration from the given file and return it in data type.
 loadFileConfig :: MonadIO m => FilePath -> m PartialConfig
-loadFileConfig = Toml.decodeFile configT
+loadFileConfig = Toml.decodeFile configCodec
diff --git a/summoner-cli/src/Summoner/Process.hs b/summoner-cli/src/Summoner/Process.hs
diff --git a/summoner-cli/src/Summoner/Project.hs b/summoner-cli/src/Summoner/Project.hs
@@ -5,6 +5,7 @@
 module Summoner.Project
        ( generateProject
        , initializeProject
+       , fetchSources
        ) where
 
 import Data.List (intersect)
@@ -21,15 +22,16 @@ import Summoner.Default (currentYear, defaultDescription, defaultGHC)
 import Summoner.GhcVer (oldGhcs, parseGhcVer, showGhcVer)
 import Summoner.License (LicenseName (..), customizeLicense, fetchLicense, licenseShortDesc,
                          parseLicenseName)
-import Summoner.Process ()
 import Summoner.Question (YesNoPrompt (..), checkUniqueName, choose, falseMessage,
                           mkDefaultYesNoPrompt, query, queryDef, queryManyRepeatOnFail,
                           queryWithPredicate, targetMessageWithText, trueMessage)
 import Summoner.Settings (Settings (..))
-import Summoner.Source (fetchSource)
+import Summoner.Source (Source, fetchSource)
 import Summoner.Template (createProjectTemplate)
 import Summoner.Text (intercalateMap, moduleNameValid, packageNameValid, packageToModule)
-import Summoner.Tree (showBoldTree, traverseTree)
+import Summoner.Tree (TreeFs, pathToTree, showBoldTree, traverseTree)
+
+import qualified Data.Map.Strict as Map
 
 
 -- | Generate the project.
@@ -112,9 +114,17 @@ generateProject isOffline projectName Config{..} = do
     when (oldGhcIncluded && settingsStack && settingsTravis) $
         warningMessage "Old GHC versions won't be included into Stack matrix at Travis CI because of the Stack issue with newer Cabal versions."
 
-    let fetchLast = maybe (pure Nothing) (fetchSource isOffline) . getLast
-    settingsStylish      <- fetchLast cStylish
-    settingsContributing <- fetchLast cContributing
+    let fetchLast :: Text -> Last Source -> IO (Maybe Text)
+        fetchLast option (Last mSource) = case mSource of
+            Nothing -> pure Nothing
+            Just source -> do
+                let msg = [text|The option '${option}' is deprecated. Use 'files' instead.|]
+                warningMessage msg
+                fetchSource isOffline source
+
+    settingsStylish      <- fetchLast "stylish.{url,file,link}" cStylish
+    settingsContributing <- fetchLast "contributing.{url,file,link}" cContributing
+    settingsFiles <- fetchSources isOffline cFiles
 
     -- Create project data from all variables in scope
     -- and make a project from it.
@@ -203,6 +213,20 @@ initializeProject settings@Settings{..} = do
     when settingsGitHub $ doGithubCommands settings
     beautyPrint [bold, setColor Green] "\nJob's done\n"
 
+{- | This function fetches contents of extra file sources.
+-}
+fetchSources :: Bool -> Map FilePath Source -> IO [TreeFs]
+fetchSources isOffline = mapMaybeM sourceToTree . Map.toList
+  where
+    sourceToTree :: (FilePath, Source) -> IO (Maybe TreeFs)
+    sourceToTree (path, source) = do
+        infoMessage $ "Fetching content of the extra file: " <> toText path
+        fetchSource isOffline source >>= \case
+            Nothing -> do
+                errorMessage $ "Error fetching: " <> toText path
+                pure Nothing
+            Just content -> pure $ Just $ pathToTree path content
+
 -- | From the given 'Settings' creates the project.
 createProjectDirectory :: Settings -> IO ()
 createProjectDirectory settings@Settings{..} = do

diff --git a/summoner-cli/src/Summoner/Settings.hs b/summoner-cli/src/Summoner/Settings.hs
@@ -9,6 +9,7 @@ module Summoner.Settings
 import Summoner.CustomPrelude (CustomPrelude)
 import Summoner.GhcVer (GhcVer)
 import Summoner.License (License, LicenseName)
+import Summoner.Tree (TreeFs)
 
 
 -- | Data needed for project creation.
@@ -41,6 +42,7 @@ data Settings = Settings
     , settingsStylish        :: !(Maybe Text) -- ^ @.stylish-haskell.yaml@ file
     , settingsContributing   :: !(Maybe Text) -- ^ @CONTRIBUTING.md@ file
     , settingsNoUpload       :: !Bool  -- ^ do not upload to GitHub
+    , settingsFiles          :: ![TreeFs]  -- ^ Tree nodes of extra files
     } deriving stock (Show)
 
 -- | Enum for supported build tools.

diff --git a/summoner-cli/src/Summoner/Source.hs b/summoner-cli/src/Summoner/Source.hs
@@ -3,6 +3,7 @@
 module Summoner.Source
        ( Source (..)
        , sourceT
+       , sourceCodec
        , fetchSource
        ) where
 
@@ -33,18 +34,22 @@ showSource = \case
     File _ -> "File"
     Link _ -> "Link"
 
+-- TODO: return Maybe
 matchUrl :: Source -> Either TomlBiMapError Text
 matchUrl (Url url) = Right url
 matchUrl e         = Left $ WrongConstructor "Url" $ showSource e
 
+-- TODO: return Maybe
 matchFile :: Source -> Either TomlBiMapError FilePath
 matchFile (File file) = Right file
 matchFile e           = Left $ WrongConstructor "File" $ showSource e
 
+-- TODO: return Maybe
 matchLink :: Source -> Either TomlBiMapError Text
 matchLink (Link link) = Right link
 matchLink e           = Left $ WrongConstructor "Link" $ showSource e
 
+-- DEPRECATED: To be removed in 2.0
 sourceT :: Key -> TomlCodec Source
 sourceT nm = Toml.match (_Url  >>> Toml._Text)   (nm <> "url")
          <|> Toml.match (_File >>> Toml._String) (nm <> "file")
@@ -59,6 +64,16 @@ sourceT nm = Toml.match (_Url  >>> Toml._Text)   (nm <> "url")
     _Link :: TomlBiMap Source Text
     _Link = Toml.prism Link matchLink
 
+{- | This 'TomlCodec' is used in the @files@ field of config. It decodes
+corresponding constructor from the top-level key.
+-}
+sourceCodec :: TomlCodec Source
+sourceCodec = asum
+    [ Toml.dimatch (rightToMaybe . matchUrl) Url (Toml.text "url")
+    , Toml.dimatch (rightToMaybe . matchFile) File (Toml.string "file")
+    , Toml.dimatch (rightToMaybe . matchLink) Link (Toml.text "link")
+    ]
+
 fetchSource :: Bool -> Source -> IO (Maybe Text)
 fetchSource isOffline = \case
     File path -> catch (Just <$> readFileText path) (fileError path)

diff --git a/summoner-cli/src/Summoner/Template.hs b/summoner-cli/src/Summoner/Template.hs
@@ -10,22 +10,29 @@ import Summoner.Template.Doc (docFiles)
 import Summoner.Template.GitHub (gitHubFiles)
 import Summoner.Template.Haskell (haskellFiles)
 import Summoner.Template.Stack (stackFiles)
-import Summoner.Tree (TreeFs (..))
+import Summoner.Tree (TreeFs (..), insertTree)
 
 
 -- | Creating tree structure of the project.
 createProjectTemplate :: Settings -> TreeFs
-createProjectTemplate settings@Settings{..} = Dir (toString settingsRepo) $ concat
-    [ cabal
-    , stack
-    , haskell
-    , docs
-    , gitHub
-    ]
+createProjectTemplate settings@Settings{..} = Dir
+    (toString settingsRepo)
+    (foldr insertTree generatedFiles settingsFiles)
   where
+    generatedFiles :: [TreeFs]
+    generatedFiles = concat
+        [ cabal
+        , stack
+        , haskell
+        , docs
+        , gitHub
+        ]
+
     cabal, stack :: [TreeFs]
-    cabal   = [cabalFile settings]
-    stack   = memptyIfFalse settingsStack $ stackFiles settings  -- TODO: write more elegant
+    cabal = [cabalFile settings]
+    stack = memptyIfFalse settingsStack $ stackFiles settings
+
+    haskell, docs, gitHub :: [TreeFs]
     haskell = haskellFiles settings
     docs    = docFiles settings
     gitHub  = gitHubFiles settings