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

* [#333] Use key-value map for extra files

Resolves #333

* Fix stack

stack-nightly.yaml

@@ -1,4 +1,4 @@
-resolver: nightly-2019-10-31
+resolver: nightly-2019-11-04
 
 packages:
   - summoner-cli/
@@ -7,7 +7,6 @@ packages:
 extra-deps:
   - base-noprelude-4.13.0.0
   - brick-0.50
-  - relude-0.6.0.0
   - vty-5.26
 
   - github: kowainik/tomland

stack.yaml

@@ -6,6 +6,7 @@ packages:
 
 extra-deps:
   - optparse-applicative-0.15.0.0
+  - relude-0.6.0.0
 
   - github: kowainik/tomland
     commit: f06fa1c72a4c4cf5dd6fbc988d920f62d1eb30af

summoner-cli/src/Summoner.hs

@@ -12,6 +12,6 @@ import Summoner.License as Summoner
 import Summoner.Project as Summoner
 import Summoner.Question as Summoner
 import Summoner.Settings as Summoner
-import Summoner.Shell as Summoner
 import Summoner.Template as Summoner
 import Summoner.Text as Summoner
+import Summoner.Tree as Summoner

summoner-cli/src/Summoner/Project.hs

@@ -5,6 +5,7 @@
 module Summoner.Project
        ( generateProject
        , initializeProject
+       , fetchSources
        ) where
 
 import Data.List (intersect)
@@ -25,11 +26,10 @@ import Summoner.Question (YesNoPrompt (..), checkUniqueName, choose, falseMessag
                           mkDefaultYesNoPrompt, query, queryDef, queryManyRepeatOnFail,
                           queryWithPredicate, targetMessageWithText, trueMessage)
 import Summoner.Settings (Settings (..))
-import Summoner.Shell (createFileWithParents)
 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
 
@@ -124,11 +124,11 @@ generateProject isOffline projectName Config{..} = do
 
     settingsStylish      <- fetchLast "stylish.{url,file,link}" cStylish
     settingsContributing <- fetchLast "contributing.{url,file,link}" cContributing
-    let settingsFiles = cFiles
+    settingsFiles <- fetchSources isOffline cFiles
 
     -- Create project data from all variables in scope
     -- and make a project from it.
-    initializeProject isOffline Settings{..}
+    initializeProject Settings{..}
  where
     decisionIf :: Bool -> YesNoPrompt -> Decision -> IO Bool
     decisionIf p ynPrompt decision = if p
@@ -207,16 +207,26 @@ generateProject isOffline projectName Config{..} = do
         stackMsg c = targetMessageWithText c "Stack" "used in this project"
 
 -- | Creates the directory and run GitHub commands.
-initializeProject :: Bool -> Settings -> IO ()
-initializeProject isOffline settings@Settings{..} = do
+initializeProject :: Settings -> IO ()
+initializeProject settings@Settings{..} = do
     createProjectDirectory settings
-    for_ (Map.toList settingsFiles) $ \(path, source) -> do
-        infoMessage $ "Creating extra file: " <> toText path
-        whenJustM (fetchSource isOffline source) (createFileWithParents path)
-
     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

summoner-cli/src/Summoner/Settings.hs

@@ -8,8 +8,8 @@ module Summoner.Settings
 
 import Summoner.CustomPrelude (CustomPrelude)
 import Summoner.GhcVer (GhcVer)
-import Summoner.Source (Source)
 import Summoner.License (License, LicenseName)
+import Summoner.Tree (TreeFs)
 
 
 -- | Data needed for project creation.
@@ -42,7 +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          :: !(Map FilePath Source)  -- ^ Extra files
+    , settingsFiles          :: ![TreeFs]  -- ^ Tree nodes of extra files
     } deriving stock (Show)
 
 -- | Enum for supported build tools.

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

summoner-cli/src/Summoner/Tree.hs

@@ -3,11 +3,14 @@
 module Summoner.Tree
        ( TreeFs (..)
        , traverseTree
+       , pathToTree
+       , insertTree
        , showBoldTree
        , showTree
        ) where
 
 import System.Directory (createDirectoryIfMissing, withCurrentDirectory)
+import System.FilePath (splitDirectories)
 
 import Summoner.Ansi (boldCode, resetCode)
 
@@ -23,10 +26,52 @@ data TreeFs
 -- | Walks through directory tree and write file contents, creating all
 -- intermediate directories.
 traverseTree :: TreeFs -> IO ()
+traverseTree (File name content) = writeFileText name content
 traverseTree (Dir name children) = do
     createDirectoryIfMissing False name
     withCurrentDirectory name $ for_ children traverseTree
-traverseTree (File name content) = writeFileText name content
+
+{- | This function converts a string file path to the tree structure.
+
+For a path like this: @".github/workflow/ci.yml"@
+
+This function produces the following tree:
+
+@
+.github/
+└── workflow/
+    └── ci.yml
+@
+-}
+pathToTree :: FilePath -> Text -> TreeFs
+pathToTree path content =
+    let pathParts = splitDirectories path
+    in case pathParts of
+        [] -> Dir path []  -- shouldn't happen
+        x:xs -> go x xs
+  where
+    go :: FilePath -> [FilePath] -> TreeFs
+    go p [] = File p content
+    go p (x:xs) = Dir p [go x xs]
+
+{- | This functions inserts given 'TreeFs' node into the list of existing
+'TreeFs' nodes. The behavior of this function is the following:
+
+1. It merges duplicating directories.
+2. It overrides existing 'File' with the given 'TreeFs' in case of duplicates.
+-}
+insertTree :: TreeFs -> [TreeFs] -> [TreeFs]
+insertTree node [] = [node]
+insertTree node (x:xs) = case (node, x) of
+    (Dir _ _, File _ _) -> x : insertTree node xs
+    (File _ _, Dir _ _) -> x : insertTree node xs
+    (File nodePath _, File curPath _)
+        | nodePath == curPath -> node : xs
+        | otherwise -> x : insertTree node xs
+    (Dir nodePath nodeChildren, Dir curPath curChildren)
+        | nodePath == curPath ->
+            Dir nodePath (foldr insertTree curChildren nodeChildren) : xs
+        | otherwise -> x : insertTree node xs
 
 -- | Pretty shows the directory tree content.
 showBoldTree :: TreeFs -> Text
@@ -61,7 +106,7 @@ showTree isBold = unlines . showOne "  " "" ""
         let arms = replicate (length children - 1) "├" <> ["└"]
         in  concat (zipWith (showOne leader "── ") arms children)
 
--- For sorting in alphabetic order.
+-- | Extract 'TreeFs' path. Used for sorting in alphabetic order.
 treeFp :: TreeFs -> FilePath
 treeFp (Dir fp _)  = fp
 treeFp (File fp _) = fp

summoner-cli/summoner.cabal

@@ -84,7 +84,6 @@ library
                          Summoner.Project
                          Summoner.Question
                          Summoner.Settings
-                         Summoner.Shell
                          Summoner.Source
                          Summoner.Template
                            Summoner.Template.Cabal
@@ -112,7 +111,7 @@ library
                      , neat-interpolation ^>= 0.3.2.2
                      , optparse-applicative ^>= 0.15
                      , process ^>= 1.6.1.0
-                     , relude >= 0.5.0 && < 0.7
+                     , relude ^>= 0.6.0.0
                      , shellmet >= 0.0.1 && < 0.1
                      , text ^>= 1.2.3.0
                      , time >= 1.8 && < 1.10

summoner-cli/test/Test/Golden.hs

@@ -91,8 +91,9 @@ fullProject = Settings
     , settingsStylish        = Just "This is stylish-haskell.yaml\n"
     , settingsContributing   = Just "This is contributing guide\n"
     , settingsNoUpload       = True
-    , settingsFiles          = mempty
---    , settingsFiles          = Map.fromList [("extra.txt", Link "@github")]
+    , settingsFiles          =
+        [ File "extra.txt" [text|See full content of the file [here](@github)|]
+        ]
     }
   where
     mitLicense :: License

summoner-cli/test/golden/fullProject/extra.txt

@@ -0,0 +1 @@
+See full content of the file [here](@github)

summoner-tui/src/Summoner/Tui.hs

@@ -29,12 +29,13 @@ import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory,
 
 import Summoner.Ansi (errorMessage, infoMessage)
 import Summoner.CLI (Command (..), NewOpts (..), ShowOpts (..), getFinalConfig, runScript, summon)
+import Summoner.Config (ConfigP (cFiles))
 import Summoner.Decision (Decision (..))
 import Summoner.Default (defaultConfigFile)
 import Summoner.GhcVer (showGhcMeta)
 import Summoner.License (License (..), LicenseName, fetchLicense, parseLicenseName,
                          showLicenseWithDesc)
-import Summoner.Project (initializeProject)
+import Summoner.Project (fetchSources, initializeProject)
 import Summoner.Text (alignTable)
 import Summoner.Tui.Field (disabledAttr)
 import Summoner.Tui.Form (KitForm, SummonForm (..), getCurrentFocus, isActive, mkForm, recreateForm)
@@ -70,11 +71,13 @@ summonTuiNew :: NewOpts -> IO ()
 summonTuiNew newOpts@NewOpts{..} = do
     -- configure initial state for TUI application
     finalConfig <- getFinalConfig newOpts
+    files <- fetchSources newOptsOffline (cFiles finalConfig)
     configFilePath <- findConfigFile
     let initialKit = configToSummonKit
             newOptsProjectName
             newOptsOffline
             configFilePath
+            files
             finalConfig
 
     -- run TUI app
@@ -83,7 +86,7 @@ summonTuiNew newOpts@NewOpts{..} = do
     -- perform actions depending on the final state
     let kit = formState skForm
     if allFieldsValid skForm && (kit ^. shouldSummon == Yes)
-    then finalSettings kit >>= initializeProject newOptsOffline
+    then finalSettings kit >>= initializeProject
     else errorMessage "Aborting summoner"
   where
     findConfigFile :: IO (Maybe FilePath)

summoner-tui/src/Summoner/Tui/Kit.hs

@@ -76,7 +76,7 @@ import Summoner.License (LicenseName (..), customizeLicense, fetchLicense)
 import Summoner.Settings (Settings (..))
 import Summoner.Source (Source, fetchSource)
 import Summoner.Template (createProjectTemplate)
-import Summoner.Tree (showTree)
+import Summoner.Tree (TreeFs, showTree)
 
 import qualified Data.List as List (delete)
 import qualified Data.Text as T
@@ -98,7 +98,7 @@ data SummonKit = SummonKit
     , summonKitOffline      :: !Bool
     , summonKitShouldSummon :: !Decision  -- ^ Check if project needs to be created.
     , summonKitConfigFile   :: !(Maybe FilePath)  -- ^ Just if configuration file was used.
-    , summonKitExtraFiles   :: !(Map FilePath Source)
+    , summonKitExtraFiles   :: ![TreeFs]  -- ^ Extra files
     } deriving stock (Show)
 
 -- | User information.
@@ -228,9 +228,10 @@ configToSummonKit
     :: Text  -- ^ Given project name
     -> Bool    -- ^  @offline@ mode option
     -> Maybe FilePath  -- ^ Configuration file used
+    -> [TreeFs]  -- ^ Extra files
     -> Config  -- ^ Given configurations.
     -> SummonKit
-configToSummonKit cRepo cOffline cConfigFile Config{..} = SummonKit
+configToSummonKit cRepo cOffline cConfigFile files Config{..} = SummonKit
     { summonKitUser  = User
         { userOwner    = cOwner
         , userFullName = cFullName
@@ -268,7 +269,7 @@ configToSummonKit cRepo cOffline cConfigFile Config{..} = SummonKit
     , summonKitOffline      = cOffline
     , summonKitShouldSummon = Nop
     , summonKitConfigFile   = cConfigFile
-    , summonKitExtraFiles   = cFiles
+    , summonKitExtraFiles   = files
     }
   where
     kitCabal, kitStack, kitLib, kitExe :: Bool

summoner-tui/summoner-tui.cabal

@@ -72,7 +72,7 @@ library
                      , filepath ^>= 1.4.1.2
                      , microlens ^>= 0.4
                      , microlens-th ^>= 0.4
-                     , relude >= 0.5.0 && < 0.7
+                     , relude ^>= 0.6.0.0
                      , summoner ^>= 1.3.0
                      , text ^>= 1.2.3.0
                      , vty >= 5.25 && < 5.27
@@ -88,4 +88,4 @@ executable summon-tui
 
   ghc-options:         -threaded
                        -rtsopts
-                       -with-rtsopts=-N
+                       -with-rtsopts=-N