Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

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

Merged
merged 2 commits into from
Nov 5, 2019
Merged

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

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
9519637
[#333] Use key-value map for extra files
chshersh Nov 4, 2019
6f8bf23
Fix stack
chshersh Nov 4, 2019
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion summoner-cli/src/Summoner.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
30 changes: 20 additions & 10 deletions summoner-cli/src/Summoner/Project.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -5,6 +5,7 @@
module Summoner.Project
( generateProject
, initializeProject
, fetchSources
) where

import Data.List (intersect)
Expand All @@ -25,11 +26,10 @@ import Summoner.Question (YesNoPrompt (..), checkUniqueName, choose, falseMessag
mkDefaultYesNoPrompt, query, queryDef, queryManyRepeatOnFail,
targetMessageWithText, trueMessage)
import Summoner.Settings (Settings (..))
import Summoner.Shell (createFileWithParents)
import Summoner.Source (Source, fetchSource)
import Summoner.Template (createProjectTemplate)
import Summoner.Text (intercalateMap, packageToModule)
import Summoner.Tree (showBoldTree, traverseTree)
import Summoner.Tree (TreeFs, pathToTree, showBoldTree, traverseTree)

import qualified Data.Map.Strict as Map

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -197,16 +197,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
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Is this correct, that in case of download (or just file getting) failure the process of the project generation will still continue without those files?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@vrom911 I'm not sure, but implementing different logic is quite complicated. For example, if isOffile is True then all Url will fail. But maybe this is intentional and maybe I don't want things like CONTRIBUTING.md while developing locally 🤔

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yes, makes sense. By the way, where the mentioned case is handled?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It's handled here:

summoner/summoner-cli/src/Summoner/Source.hs

Lines 65 to 67 in 38d1fce

Url url -> if isOffline
then Nothing <$ infoMessage ("Ignoring fetching from URL in offline mode from source: " <> url)
else fetchUrl url `catch` urlError url

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Oh, right! Thank you 🍷

Just content -> pure $ Just $ pathToTree path content

-- | From the given 'Settings' creates the project.
createProjectDirectory :: Settings -> IO ()
createProjectDirectory settings@Settings{..} = do
Expand Down
4 changes: 2 additions & 2 deletions summoner-cli/src/Summoner/Settings.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down Expand Up @@ -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.
Expand Down
33 changes: 0 additions & 33 deletions summoner-cli/src/Summoner/Shell.hs
View file
Open in desktop

This file was deleted.

24 changes: 14 additions & 10 deletions summoner-cli/src/Summoner/Template.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -10,22 +10,26 @@ 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 settingsFiles
$ concat
[ cabal
, stack
, haskell
, docs
, gitHub
]
where
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
49 changes: 47 additions & 2 deletions summoner-cli/src/Summoner/Tree.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)

Expand All @@ -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
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't quite get this case. When this file is already in the tree, it inserts it, but if it's not, it somehow continues inserting on the next layer? How so?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Right, the implementation is not obvious, but I tried to do my best. This function always inserts node to the list, at least when it reaches the empty list at the end:

insertTree node [] = [node]

In this case, if this function finds two Files with the same path, it will replace current x with node that why it's node : xs. This is done if people want to override default files like .travis.yml or Prelude.hs with their files. If file paths are not equal, then we keep x, and we will try to insert node into xs. Eventually, we either reach the end of the list, and we will add node unconditionally, or we will find a File that has the same name and will replace it.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Hmm, but are other nodes placed unconditionally? I thought there is some kind of hierarchy so no need to go till the end of the list each time.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Well, this list is not sorted at this stage. It could be [File "foo" x, File "bar" y] or [File "bar" x, File "foo" y]. I checked the implementation, and it looks like we sort this list only when printing to terminal or in TUI.

Now, after you told this, I started to think that probably there's a better way to implement TreeFs. At least TreeFs shouldn't have duplicate filepaths but since we're using lists, it's possible to have a bug in the implementation and introduce duplicate fields.

Maybe instead of

data TreeFs
    = Dir FilePath [TreeFs]
    | File FilePath Text

we should have

data TreeFs
    = Dir (Map FilePath TreeFs)
    | File Text

The latter representation won't allow having duplicate filepaths. But I believe that the current algorithm is also correct, even if the logic is not straightforward... And changing this type is a big rewrite...

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Thank you for the clarification, Dmitrii! Yeah, I don't think that rewrite is the right step right now, and we could keep this function as it is for this PR. But let's think more about this sorting before option and create the issue if we will decide that it could work better and would become easier to maintain.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I've created the issue:

(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
Expand Down Expand Up @@ -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
3 changes: 1 addition & 2 deletions summoner-cli/summoner.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -84,7 +84,6 @@ library
Summoner.Project
Summoner.Question
Summoner.Settings
Summoner.Shell
Summoner.Source
Summoner.Template
Summoner.Template.Cabal
Expand Down Expand Up @@ -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
Expand Down
5 changes: 3 additions & 2 deletions summoner-cli/test/Test/Golden.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
1 change: 1 addition & 0 deletions summoner-cli/test/golden/fullProject/extra.txt
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
See full content of the file [here](@github)
7 changes: 5 additions & 2 deletions summoner-tui/src/Summoner/Tui.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand All @@ -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)
Expand Down
9 changes: 5 additions & 4 deletions summoner-tui/src/Summoner/Tui/Kit.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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.
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
4 changes: 2 additions & 2 deletions summoner-tui/summoner-tui.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -88,4 +88,4 @@ executable summon-tui

ghc-options: -threaded
-rtsopts
-with-rtsopts=-N
-with-rtsopts=-N