From e12819ef41fb04385f62035d0fa6e5e96481f1e9 Mon Sep 17 00:00:00 2001 From: Dmitrii Kovanikov Date: Tue, 5 Nov 2019 10:30:53 +0300 Subject: [PATCH] [#333] Use key-value map for extra files (#369) * [#333] Use key-value map for extra files Resolves #333 * Fix stack --- stack-nightly.yaml | 3 +- stack.yaml | 1 + summoner-cli/src/Summoner.hs | 2 +- summoner-cli/src/Summoner/Project.hs | 30 ++++++++---- summoner-cli/src/Summoner/Settings.hs | 4 +- summoner-cli/src/Summoner/Shell.hs | 33 ------------- summoner-cli/src/Summoner/Template.hs | 27 ++++++---- summoner-cli/src/Summoner/Tree.hs | 49 ++++++++++++++++++- summoner-cli/summoner.cabal | 3 +- summoner-cli/test/Test/Golden.hs | 5 +- .../test/golden/fullProject/extra.txt | 1 + summoner-tui/src/Summoner/Tui.hs | 7 ++- summoner-tui/src/Summoner/Tui/Kit.hs | 9 ++-- summoner-tui/summoner-tui.cabal | 4 +- 14 files changed, 106 insertions(+), 72 deletions(-) delete mode 100644 summoner-cli/src/Summoner/Shell.hs create mode 100644 summoner-cli/test/golden/fullProject/extra.txt diff --git a/stack-nightly.yaml b/stack-nightly.yaml index c3cb8f8a..df753d31 100644 --- 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,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 diff --git a/stack.yaml b/stack.yaml index 8909fe33..a80b0e3b 100644 --- a/stack.yaml +++ b/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 diff --git a/summoner-cli/src/Summoner.hs b/summoner-cli/src/Summoner.hs index 4d93c846..bc62cbe6 100644 --- a/summoner-cli/src/Summoner.hs +++ b/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 diff --git a/summoner-cli/src/Summoner/Project.hs b/summoner-cli/src/Summoner/Project.hs index b3148fe9..5adceab5 100644 --- 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) @@ -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 diff --git a/summoner-cli/src/Summoner/Settings.hs b/summoner-cli/src/Summoner/Settings.hs index ff4e1b13..2355e824 100644 --- a/summoner-cli/src/Summoner/Settings.hs +++ b/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. diff --git a/summoner-cli/src/Summoner/Shell.hs b/summoner-cli/src/Summoner/Shell.hs deleted file mode 100644 index 5cdde018..00000000 --- a/summoner-cli/src/Summoner/Shell.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} - --- | This module contains various function to work with commands. -module Summoner.Shell - ( createFileWithParents - , deleteFile - ) where - -import Control.Exception (catch) -import System.Directory (createDirectoryIfMissing, removeFile) -import System.FilePath (takeDirectory) - -import Summoner.Ansi (errorMessage) - - --- | Delete file, but just print a message if delete fails and continue instead of raising an error. -deleteFile :: FilePath -> IO () -deleteFile file = removeFile file `catch` printError - where - printError :: SomeException -> IO () - printError e = errorMessage $ "Could not delete file '" - <> toText file <> "'. " <> toText (displayException e) - -{- | This function creates all parents of a given file and writes content to the -file by path. If given a path like @foo/bar/baz/quux.txt@ it will create all -directories @foo/@, @foo/bar/@ and @foo/bar/baz/@. --} -createFileWithParents :: FilePath -> Text -> IO () -createFileWithParents path content = do - let directory = takeDirectory path - createDirectoryIfMissing True directory - writeFileText path content diff --git a/summoner-cli/src/Summoner/Template.hs b/summoner-cli/src/Summoner/Template.hs index 43f607bc..d0d46f91 100644 --- 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 diff --git a/summoner-cli/src/Summoner/Tree.hs b/summoner-cli/src/Summoner/Tree.hs index d47b805d..9f07fae2 100644 --- a/summoner-cli/src/Summoner/Tree.hs +++ b/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 diff --git a/summoner-cli/summoner.cabal b/summoner-cli/summoner.cabal index d5f226b2..e5851c21 100644 --- a/summoner-cli/summoner.cabal +++ b/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 diff --git a/summoner-cli/test/Test/Golden.hs b/summoner-cli/test/Test/Golden.hs index 7bfea0d4..9abd3205 100644 --- a/summoner-cli/test/Test/Golden.hs +++ b/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 diff --git a/summoner-cli/test/golden/fullProject/extra.txt b/summoner-cli/test/golden/fullProject/extra.txt new file mode 100644 index 00000000..9c8c2f08 --- /dev/null +++ b/summoner-cli/test/golden/fullProject/extra.txt @@ -0,0 +1 @@ +See full content of the file [here](@github) diff --git a/summoner-tui/src/Summoner/Tui.hs b/summoner-tui/src/Summoner/Tui.hs index ab9ca4f8..6564ed6b 100644 --- a/summoner-tui/src/Summoner/Tui.hs +++ b/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) diff --git a/summoner-tui/src/Summoner/Tui/Kit.hs b/summoner-tui/src/Summoner/Tui/Kit.hs index dba8ef45..3740cc24 100644 --- a/summoner-tui/src/Summoner/Tui/Kit.hs +++ b/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 diff --git a/summoner-tui/summoner-tui.cabal b/summoner-tui/summoner-tui.cabal index 8d4964c9..08b26069 100644 --- a/summoner-tui/summoner-tui.cabal +++ b/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 \ No newline at end of file + -with-rtsopts=-N