Skip to content

Comments and small refactorings in cabal init code. #6632

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.

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

Merged
merged 1 commit into from
Apr 1, 2020
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
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
79 changes: 54 additions & 25 deletions cabal-install/Distribution/Client/Init.hs
Original file line number Diff line number Diff line change
Expand Up @@ -148,8 +148,8 @@ initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do
-- Flag acquisition -----------------------------------------------------
---------------------------------------------------------------------------

-- | Fill in more details by guessing, discovering, or prompting the
-- user.
-- | Fill in more details in InitFlags by guessing, discovering, or prompting
-- the user.
extendFlags :: InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags
extendFlags pkgIx sourcePkgDb =
getSimpleProject
Expand Down Expand Up @@ -188,14 +188,6 @@ maybeToFlag = maybe NoFlag Flag
defaultCabalVersion :: Version
defaultCabalVersion = mkVersion [1,10]

displayCabalVersion :: Version -> String
displayCabalVersion v = case versionNumbers v of
[1,10] -> "1.10 (legacy)"
[2,0] -> "2.0 (+ support for Backpack, internal sub-libs, '^>=' operator)"
[2,2] -> "2.2 (+ support for 'common', 'elif', redundant commas, SPDX)"
[2,4] -> "2.4 (+ support for '**' globbing)"
_ -> display v

-- | Ask if a simple project with sensible defaults should be created.
getSimpleProject :: InitFlags -> IO InitFlags
getSimpleProject flags = do
Expand All @@ -215,7 +207,11 @@ getSimpleProject flags = do
flags { simpleProject = simpleProjFlag }


-- | Ask which version of the cabal spec to use.
-- | Get the version of the cabal spec to use.
--
-- The spec version can be specified by the InitFlags cabalVersion field. If
-- none is specified then the user is prompted to pick from a list of
-- supported versions (see code below).
getCabalVersion :: InitFlags -> IO InitFlags
getCabalVersion flags = do
cabVer <- return (flagToMaybe $ cabalVersion flags)
Expand All @@ -227,6 +223,16 @@ getCabalVersion flags = do

return $ flags { cabalVersion = maybeToFlag cabVer }

where
displayCabalVersion :: Version -> String
displayCabalVersion v = case versionNumbers v of
[1,10] -> "1.10 (legacy)"
[2,0] -> "2.0 (+ support for Backpack, internal sub-libs, '^>=' operator)"
[2,2] -> "2.2 (+ support for 'common', 'elif', redundant commas, SPDX)"
[2,4] -> "2.4 (+ support for '**' globbing)"
_ -> display v



-- | Get the package name: use the package directory (supplied, or the current
-- directory by default) as a guess. It looks at the SourcePackageDb to avoid
Expand Down Expand Up @@ -269,7 +275,10 @@ getVersion flags = do
?>> return v
return $ flags { version = maybeToFlag v' }

-- | Choose a license.
-- | Choose a license for the package.
--
-- The license can come from Initflags (license field), if it is not present
-- then prompt the user from a predefined list of licenses.
getLicense :: InitFlags -> IO InitFlags
getLicense flags = do
lic <- return (flagToMaybe $ license flags)
Expand Down Expand Up @@ -324,7 +333,7 @@ getAuthorInfo flags = do
, email = maybeToFlag authorEmail'
}

-- | Prompt for a homepage URL.
-- | Prompt for a homepage URL for the package.
getHomepage :: InitFlags -> IO InitFlags
getHomepage flags = do
hp <- queryHomepage
Expand Down Expand Up @@ -435,7 +444,7 @@ getGenTests flags = do
(Just True))
return $ flags { initializeTestSuite = maybeToFlag genTests }

-- | Ask for the test root directory.
-- | Ask for the test suite root directory.
getTestDir :: InitFlags -> IO InitFlags
getTestDir flags = do
dirs <- return (testDirs flags)
Expand All @@ -447,7 +456,7 @@ getTestDir flags = do

return $ flags { testDirs = dirs }

-- | Ask for the base language of the package.
-- | Ask for the Haskell base language of the package.
getLanguage :: InitFlags -> IO InitFlags
getLanguage flags = do
lang <- return (flagToMaybe $ language flags)
Expand Down Expand Up @@ -600,6 +609,8 @@ getModulesBuildToolsAndDeps pkgIx flags = do
, otherExts = exts
}

-- | Given a list of imported modules, retrieve the list of dependencies that
-- provide those modules.
importsToDeps :: InitFlags -> [ModuleName] -> InstalledPackageIndex -> IO [P.Dependency]
importsToDeps flags mods pkgIx = do

Expand Down Expand Up @@ -705,8 +716,9 @@ promptStr :: String -> Maybe String -> IO String
promptStr = promptDefault' Just id

-- | Create a yes/no prompt with optional default value.
--
promptYesNo :: String -> Maybe Bool -> IO Bool
promptYesNo :: String -- ^ prompt message
-> Maybe Bool -- ^ optional default value
-> IO Bool
promptYesNo =
promptDefault' recogniseYesNo showYesNo
where
Expand Down Expand Up @@ -746,6 +758,8 @@ mkDefPrompt pr def = pr ++ "?" ++ defStr def
where defStr Nothing = " "
defStr (Just s) = " [default: " ++ s ++ "] "

-- | Create a prompt from a list of items, where no selected items is
-- valid and will be represented as a return value of 'Nothing'.
promptListOptional :: (Text t, Eq t)
=> String -- ^ prompt
-> [t] -- ^ choices
Expand Down Expand Up @@ -806,10 +820,18 @@ promptList' displayItem numChoices choices def other = do
-- File generation ------------------------------------------------------
---------------------------------------------------------------------------

-- | Write the LICENSE file, as specified in the InitFlags license field.
--
-- For licences that contain the author's name(s), the values are taken
-- from the 'authors' field of 'InitFlags', and if not specified will
-- be the string "???".
--
-- If the license type is unknown no license file will be created and
-- a warning will be raised.
writeLicense :: InitFlags -> IO ()
writeLicense flags = do
message flags "\nGenerating LICENSE..."
year <- show <$> getYear
year <- show <$> getCurrentYear
let authors = fromMaybe "???" . flagToMaybe . author $ flags
let licenseFile =
case license flags of
Expand Down Expand Up @@ -852,14 +874,16 @@ writeLicense flags = do
Just licenseText -> writeFileSafe flags "LICENSE" licenseText
Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself."

getYear :: IO Integer
getYear = do
-- | Returns the current calendar year.
getCurrentYear :: IO Integer
getCurrentYear = do
u <- getCurrentTime
z <- getCurrentTimeZone
let l = utcToLocalTime z u
(y, _, _) = toGregorian $ localDay l
return y

-- | Writes the changelog to the current directory.
writeChangeLog :: InitFlags -> IO ()
writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do
message flags ("Generating "++ defaultChangeLog ++"...")
Expand All @@ -875,8 +899,9 @@ writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc
pname = maybe "" display $ flagToMaybe $ packageName flags
pver = maybe "" display $ flagToMaybe $ version flags



-- | Creates and writes the initialized .cabal file.
--
-- Returns @False@ if no package name is specified, @True@ otherwise.
writeCabalFile :: InitFlags -> IO Bool
writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do
message flags "Error: no package name provided."
Expand Down Expand Up @@ -944,7 +969,7 @@ createMainHs flags =
Flag x -> x
NoFlag -> error "createMainHs: no mainIs"

--- | Write a main file if it doesn't already exist.
-- | Write a main file if it doesn't already exist.
writeMainHs :: InitFlags -> FilePath -> IO ()
writeMainHs flags mainPath = do
dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)
Expand All @@ -954,7 +979,7 @@ writeMainHs flags mainPath = do
message flags $ "Generating " ++ mainPath ++ "..."
writeFileSafe flags mainFullPath (mainHs flags)

-- | Check that a main file exists.
-- | Returns true if a main file exists.
hasMainHs :: InitFlags -> Bool
hasMainHs flags = case mainIs flags of
Flag _ -> (packageType flags == Flag Executable
Expand Down Expand Up @@ -991,6 +1016,7 @@ mainHs flags = (unlines . map prependPrefix) $ case packageType flags of
Flag mainPath -> takeExtension mainPath == ".lhs"
_ -> False

-- | The name of the test file to generate (if --tests is specified).
testFile :: String
testFile = "MyLibTest.hs"

Expand All @@ -1003,7 +1029,7 @@ createTestHs flags =
Just (testPath:_) -> writeTestHs flags (testPath </> testFile)
_ -> writeMainHs flags testFile

--- | Write a test file.
-- | Write a test file.
writeTestHs :: InitFlags -> FilePath -> IO ()
writeTestHs flags testPath = do
dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)
Expand Down Expand Up @@ -1034,6 +1060,9 @@ moveExistingFile flags fileName =
message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName
copyFile fileName newName


-- | Given a file path find a new name for the file that does not
-- already exist.
findNewName :: FilePath -> IO FilePath
findNewName oldName = findNewName' 0
where
Expand Down
10 changes: 10 additions & 0 deletions cabal-install/Distribution/Client/Init/Licenses.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,13 @@
{-|
Module : Distribution.Client.Init.Licenses

Description : Factory functions for producing known license types.

License : BSD-like
Maintainer : cabal-devel@haskell.org
Stability : provisional
Portability : portable
-}
module Distribution.Client.Init.Licenses
( License
, bsd2
Expand Down
2 changes: 1 addition & 1 deletion cabal-install/Distribution/Client/Init/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -103,7 +103,7 @@ instance Monoid InitFlags where
instance Semigroup InitFlags where
(<>) = gmappend

-- | Some common package categories.
-- | Some common package categories (non-exhaustive list).
data Category
= Codec
| Concurrency
Expand Down