Commit 2fa83023 authored by Oleg Grenrus's avatar Oleg Grenrus

Improve `cabal init` code a bit

- Always ask for SPDX expression, we can "convert" them to old format
- No default license
- Add cabal-version: 3.0 to the list
- cabal-version is asked using CabalSpecVersion type
- seems to fix what #6619 tries to fix:

```
% /code/shared-haskell/cabal/dist-newstyle/build/x86_64-linux/ghc-8.8.3/cabal-install-3.3.0.0/x/cabal/build/cabal/cabal init -l 'FOO AND BAR'
Cannot parse license: FOO AND BAR
CallStack (from HasCallStack):
  error, called at ./Distribution/ReadE.hs:42:24 in Cabal-3.3.0.0-inplace:Distribution.ReadE
```

an error, but it doesn't loop.
parent 79d28ceb
......@@ -61,6 +61,7 @@ import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import qualified Distribution.Client.Init.Types as IT
( InitFlags(..) )
import qualified Distribution.Client.Init.Defaults as IT
import Distribution.Client.Setup
( GlobalFlags(..), globalCommand, defaultGlobalFlags
, ConfigExFlags(..), configureExOptions, defaultConfigExFlags
......@@ -74,8 +75,6 @@ import Distribution.Client.CmdInstall.ClientInstallFlags
import Distribution.Utils.NubList
( NubList, fromNubList, toNubList, overNubList )
import Distribution.License
( License(BSD3) )
import Distribution.Simple.Compiler
( DebugInfoLevel(..), OptimisationLevel(..) )
import Distribution.Simple.Setup
......@@ -114,8 +113,6 @@ import Distribution.Compiler
( CompilerFlavor(..), defaultCompilerFlavor )
import Distribution.Verbosity
( Verbosity, normal )
import Distribution.Version
( mkVersion )
import Distribution.Solver.Types.ConstraintSource
......@@ -851,9 +848,9 @@ commentSavedConfig = do
},
savedInitFlags = mempty {
IT.interactive = toFlag False,
IT.cabalVersion = toFlag (mkVersion [2,4]),
IT.cabalVersion = toFlag IT.defaultCabalVersion,
IT.language = toFlag Haskell2010,
IT.license = toFlag BSD3,
IT.license = NoFlag,
IT.sourceDirs = Nothing,
IT.applicationDirs = Nothing
},
......
......@@ -31,8 +31,6 @@ import System.Directory
import System.FilePath
( (</>), takeBaseName, equalFilePath )
import Data.List
( (\\) )
import qualified Data.List.NonEmpty as NE
import Data.Function
( on )
......@@ -43,8 +41,10 @@ import Control.Monad
import Control.Arrow
( (&&&), (***) )
import Distribution.CabalSpecVersion
( CabalSpecVersion (..), showCabalSpecVersion )
import Distribution.Version
( Version, mkVersion, alterVersion, versionNumbers, majorBoundVersion
( Version, mkVersion, alterVersion, majorBoundVersion
, orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange )
import Distribution.Verbosity
( Verbosity )
......@@ -53,6 +53,7 @@ import Distribution.ModuleName
import Distribution.InstalledPackageInfo
( InstalledPackageInfo, exposed )
import qualified Distribution.Package as P
import qualified Distribution.SPDX as SPDX
import Distribution.Types.LibraryName
( LibraryName(..) )
import Language.Haskell.Extension ( Language(..) )
......@@ -75,10 +76,6 @@ import Distribution.Client.Init.Heuristics
SourceFileEntry(..),
scanForModules, neededBuildPrograms )
import Distribution.License
( License(..), knownLicenses, licenseToSPDX )
import qualified Distribution.SPDX as SPDX
import Distribution.Simple.Setup
( Flag(..), flagToMaybe )
import Distribution.Simple.Configure
......@@ -123,8 +120,8 @@ initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do
initFlags' <- extendFlags installedPkgIndex sourcePkgDb initFlags
case license initFlags' of
Flag PublicDomain -> return ()
_ -> writeLicense initFlags'
Flag SPDX.NONE -> return ()
_ -> writeLicense initFlags'
writeChangeLog initFlags'
createDirectories (sourceDirs initFlags')
createLibHs initFlags'
......@@ -189,7 +186,7 @@ getSimpleProject flags = do
flags { interactive = Flag False
, simpleProject = Flag True
, packageType = Flag LibraryAndExecutable
, cabalVersion = Flag (mkVersion [2,4])
, cabalVersion = Flag defaultCabalVersion
}
simpleProjFlag@_ ->
flags { simpleProject = simpleProjFlag }
......@@ -205,20 +202,21 @@ getCabalVersion flags = do
cabVer <- return (flagToMaybe $ cabalVersion flags)
?>> maybePrompt flags (either (const defaultCabalVersion) id `fmap`
promptList "Please choose version of the Cabal specification to use"
[mkVersion [1,10], mkVersion [2,0], mkVersion [2,2], mkVersion [2,4]]
[CabalSpecV1_10, CabalSpecV2_0, CabalSpecV2_2, CabalSpecV2_4, CabalSpecV3_0]
(Just defaultCabalVersion) displayCabalVersion False)
?>> return (Just defaultCabalVersion)
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
displayCabalVersion :: CabalSpecVersion -> String
displayCabalVersion v = case v of
CabalSpecV1_10 -> "1.10 (legacy)"
CabalSpecV2_0 -> "2.0 (+ support for Backpack, internal sub-libs, '^>=' operator)"
CabalSpecV2_2 -> "2.2 (+ support for 'common', 'elif', redundant commas, SPDX)"
CabalSpecV2_4 -> "2.4 (+ support for '**' globbing)"
CabalSpecV3_0 -> "3.0 (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)"
_ -> showCabalSpecVersion v
......@@ -269,39 +267,44 @@ getVersion flags = do
-- then prompt the user from a predefined list of licenses.
getLicense :: InitFlags -> IO InitFlags
getLicense flags = do
lic <- return (flagToMaybe $ license flags)
?>> fmap (fmap (either UnknownLicense id))
(maybePrompt flags
(promptList "Please choose a license" listedLicenses
(Just BSD3) displayLicense True))
case checkLicenseInvalid lic of
Just msg -> putStrLn msg >> getLicense flags
Nothing -> return $ flags { license = maybeToFlag lic }
elic <- return (fmap Right $ flagToMaybe $ license flags)
?>> maybePrompt flags (promptList "Please choose a license" listedLicenses Nothing prettyShow True)
case elic of
Nothing -> return flags { license = NoFlag }
Just (Right lic) -> return flags { license = Flag lic }
Just (Left str) -> case eitherParsec str of
Right lic -> return flags { license = Flag lic }
-- on error, loop
Left err -> do
putStrLn "The license must be a valid SPDX expression."
putStrLn err
getLicense flags
where
displayLicense l | needSpdx = prettyShow (licenseToSPDX l)
| otherwise = display l
checkLicenseInvalid (Just (UnknownLicense t))
| needSpdx = case eitherParsec t :: Either String SPDX.License of
Right _ -> Nothing
Left _ -> Just "\nThe license must be a valid SPDX expression."
| otherwise = if any (not . isAlphaNum) t
then Just promptInvalidOtherLicenseMsg
else Nothing
checkLicenseInvalid _ = Nothing
promptInvalidOtherLicenseMsg = "\nThe license must be alphanumeric. " ++
"If your license name has many words, " ++
"the convention is to use camel case (e.g. PublicDomain). " ++
"Please choose a different license."
-- perfectly we'll have this and writeLicense (in FileCreators)
-- in a single file
listedLicenses =
knownLicenses \\ [GPL Nothing, LGPL Nothing, AGPL Nothing
, Apache Nothing, OtherLicense]
needSpdx = maybe False (>= mkVersion [2,2]) $ flagToMaybe (cabalVersion flags)
SPDX.NONE :
map (\lid -> SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing))
[ SPDX.BSD_2_Clause
, SPDX.BSD_3_Clause
, SPDX.Apache_2_0
, SPDX.MIT
, SPDX.MPL_2_0
, SPDX.ISC
, SPDX.GPL_2_0_only
, SPDX.GPL_3_0_only
, SPDX.LGPL_2_1_only
, SPDX.LGPL_3_0_only
, SPDX.AGPL_3_0_only
, SPDX.GPL_2_0_or_later
, SPDX.GPL_3_0_or_later
, SPDX.LGPL_2_1_or_later
, SPDX.LGPL_3_0_or_later
, SPDX.AGPL_3_0_or_later
]
-- | The author's name and email. Prompt, or try to guess from an existing
-- darcs repo.
......@@ -641,7 +644,7 @@ chooseDep flags (m, Just ps)
where
pkgGroups = NE.groupBy ((==) `on` P.pkgName) (map P.packageId ps)
desugar = maybe True (< mkVersion [2]) $ flagToMaybe (cabalVersion flags)
desugar = maybe True (< CabalSpecV2_0) $ flagToMaybe (cabalVersion flags)
-- Given a list of available versions of the same package, pick a dependency.
toDep :: NonEmpty P.PackageIdentifier -> IO P.Dependency
......
......@@ -21,11 +21,11 @@ import Distribution.ModuleName
( ModuleName ) -- And for the Text instance
import qualified Distribution.ModuleName as ModuleName
( fromString )
import Distribution.Version
( Version, mkVersion )
import Distribution.CabalSpecVersion
( CabalSpecVersion (..))
defaultCabalVersion :: Version
defaultCabalVersion = mkVersion [1,10]
defaultCabalVersion :: CabalSpecVersion
defaultCabalVersion = CabalSpecV2_4
myLibModule :: ModuleName
myLibModule = ModuleName.fromString "MyLib"
......@@ -49,10 +49,11 @@ import Distribution.Client.Init.Utils
import Distribution.Client.Init.Types
( InitFlags(..), BuildType(..), PackageType(..) )
import Distribution.CabalSpecVersion
import Distribution.Deprecated.Text
( display, Text(..) )
import Distribution.License
( License(..), licenseToSPDX )
( licenseFromSPDX )
import qualified Distribution.ModuleName as ModuleName
( toFilePath )
import qualified Distribution.Package as P
......@@ -63,8 +64,8 @@ import Distribution.Simple.Utils
( dropWhileEndLE )
import Distribution.Pretty
( prettyShow )
import Distribution.Version
( mkVersion, orLaterVersion )
import qualified Distribution.SPDX as SPDX
---------------------------------------------------------------------------
......@@ -84,40 +85,31 @@ writeLicense flags = do
message flags "\nGenerating LICENSE..."
year <- show <$> getCurrentYear
let authors = fromMaybe "???" . flagToMaybe . author $ flags
let isSimpleLicense :: SPDX.License -> Maybe SPDX.LicenseId
isSimpleLicense (SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) = Just lid
isSimpleLicense _ = Nothing
let licenseFile =
case license flags of
Flag BSD2
-> Just $ bsd2 authors year
Flag BSD3
-> Just $ bsd3 authors year
Flag (GPL (Just v)) | v == mkVersion [2]
-> Just gplv2
Flag (GPL (Just v)) | v == mkVersion [3]
-> Just gplv3
Flag (LGPL (Just v)) | v == mkVersion [2,1]
-> Just lgpl21
Flag (LGPL (Just v)) | v == mkVersion [3]
-> Just lgpl3
Flag (AGPL (Just v)) | v == mkVersion [3]
-> Just agplv3
Flag (Apache (Just v)) | v == mkVersion [2,0]
-> Just apache20
Flag MIT
-> Just $ mit authors year
Flag (MPL v) | v == mkVersion [2,0]
-> Just mpl20
Flag ISC
-> Just $ isc authors year
case flagToMaybe (license flags) >>= isSimpleLicense of
Just SPDX.BSD_2_Clause -> Just $ bsd2 authors year
Just SPDX.BSD_3_Clause -> Just $ bsd3 authors year
Just SPDX.Apache_2_0 -> Just apache20
Just SPDX.MIT -> Just $ mit authors year
Just SPDX.MPL_2_0 -> Just mpl20
Just SPDX.ISC -> Just $ isc authors year
-- GNU license come in "only" and "or-later" flavours
-- license file used are the same.
Just SPDX.GPL_2_0_only -> Just gplv2
Just SPDX.GPL_3_0_only -> Just gplv3
Just SPDX.LGPL_2_1_only -> Just lgpl21
Just SPDX.LGPL_3_0_only -> Just lgpl3
Just SPDX.AGPL_3_0_only -> Just agplv3
Just SPDX.GPL_2_0_or_later -> Just gplv2
Just SPDX.GPL_3_0_or_later -> Just gplv3
Just SPDX.LGPL_2_1_or_later -> Just lgpl21
Just SPDX.LGPL_3_0_or_later -> Just lgpl3
Just SPDX.AGPL_3_0_or_later -> Just agplv3
_ -> Nothing
......@@ -345,11 +337,11 @@ generateCabalFile fileName c = trimTrailingWS $
(++ "\n") .
renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $
-- Starting with 2.2 the `cabal-version` field needs to be the first line of the PD
(if specVer < mkVersion [1,12]
then field "cabal-version" (Flag $ orLaterVersion specVer) -- legacy
else field "cabal-version" (Flag $ specVer))
Nothing -- NB: the first line must be the 'cabal-version' declaration
False
(if specVer < CabalSpecV1_12
then fieldS "cabal-version" (Flag $ ">=" ++ showCabalSpecVersion specVer)
else fieldS "cabal-version" (Flag $ showCabalSpecVersion specVer))
Nothing
False
$$
(if minimal c /= Flag True
then showComment (Just $ "Initial package description '" ++ fileName ++ "' generated "
......@@ -389,8 +381,9 @@ generateCabalFile fileName c = trimTrailingWS $
(Just "The license under which the package is released.")
True
, case (license c) of
Flag PublicDomain -> empty
, case license c of
NoFlag -> empty
Flag SPDX.NONE -> empty
_ -> fieldS "license-file" (Flag "LICENSE")
(Just "The file containing the license text.")
True
......@@ -403,17 +396,15 @@ generateCabalFile fileName c = trimTrailingWS $
(Just "An email address to which users can send suggestions, bug reports, and patches.")
True
, case (license c) of
Flag PublicDomain -> empty
_ -> fieldS "copyright" NoFlag
(Just "A copyright notice.")
True
, fieldS "copyright" NoFlag
(Just "A copyright notice.")
True
, fieldS "category" (either id display `fmap` category c)
Nothing
True
, fieldS "build-type" (if specVer >= mkVersion [2,2] then NoFlag else Flag "Simple")
, fieldS "build-type" (if specVer >= CabalSpecV2_2 then NoFlag else Flag "Simple")
Nothing
False
......@@ -432,11 +423,8 @@ generateCabalFile fileName c = trimTrailingWS $
where
specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c)
licenseStr | specVer < mkVersion [2,2] = prettyShow `fmap` license c
| otherwise = go `fmap` license c
where
go (UnknownLicense s) = s
go l = prettyShow (licenseToSPDX l)
licenseStr | specVer < CabalSpecV2_2 = prettyShow . licenseFromSPDX <$> license c
| otherwise = prettyShow <$> license c
generateBuildInfo :: BuildType -> InitFlags -> Doc
generateBuildInfo buildType c' = vcat
......
......@@ -15,16 +15,16 @@
-----------------------------------------------------------------------------
module Distribution.Client.Init.Types where
import Distribution.Simple.Setup
( Flag(..) )
import Distribution.Simple.Setup (Flag(..), toFlag )
import Distribution.Types.Dependency as P
import Distribution.Compat.Semigroup
import Distribution.Version
import Distribution.Verbosity
import qualified Distribution.Package as P
import Distribution.License
import Distribution.SPDX.License (License)
import Distribution.ModuleName
import Distribution.CabalSpecVersion
import Language.Haskell.Extension ( Language(..), Extension )
import qualified Text.PrettyPrint as Disp
......@@ -48,7 +48,7 @@ data InitFlags =
, packageName :: Flag P.PackageName
, version :: Flag Version
, cabalVersion :: Flag Version
, cabalVersion :: Flag CabalSpecVersion
, license :: Flag License
, author :: Flag String
, email :: Flag String
......@@ -103,6 +103,11 @@ instance Monoid InitFlags where
instance Semigroup InitFlags where
(<>) = gmappend
defaultInitFlags :: InitFlags
defaultInitFlags = mempty
{ initVerbosity = toFlag normal
}
-- | Some common package categories (non-exhaustive list).
data Category
= Codec
......
......@@ -79,7 +79,7 @@ import Distribution.Client.Dependency.Types
import Distribution.Client.IndexUtils.IndexState
( TotalIndexState, headTotalIndexState )
import qualified Distribution.Client.Init.Types as IT
( InitFlags(..), PackageType(..) )
( InitFlags(..), PackageType(..), defaultInitFlags )
import Distribution.Client.Targets
( UserConstraint, readUserConstraint )
import Distribution.Utils.NubList
......@@ -142,6 +142,7 @@ import Distribution.Client.GlobalFlags
, RepoContext(..), withRepoContext
)
import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions)
import Distribution.Parsec.Newtypes (SpecVersion (..))
import Data.List
( deleteFirstsBy )
......@@ -2251,12 +2252,6 @@ instance Semigroup UploadFlags where
-- * Init flags
-- ------------------------------------------------------------
emptyInitFlags :: IT.InitFlags
emptyInitFlags = mempty
defaultInitFlags :: IT.InitFlags
defaultInitFlags = emptyInitFlags { IT.initVerbosity = toFlag normal }
initCommand :: CommandUI IT.InitFlags
initCommand = CommandUI {
commandName = "init",
......@@ -2274,7 +2269,7 @@ initCommand = CommandUI {
commandNotes = Nothing,
commandUsage = \pname ->
"Usage: " ++ pname ++ " init [FLAGS]\n",
commandDefaultFlags = defaultInitFlags,
commandDefaultFlags = IT.defaultInitFlags,
commandOptions = initOptions
}
......@@ -2313,30 +2308,30 @@ initOptions _ =
, option ['p'] ["package-name"]
"Name of the Cabal package to create."
IT.packageName (\v flags -> flags { IT.packageName = v })
(reqArg "PACKAGE" (readP_to_E ("Cannot parse package name: "++)
(toFlag `fmap` parse))
(flagToList . fmap display))
(reqArg "PACKAGE" (parsecToReadE ("Cannot parse package name: "++)
(toFlag `fmap` parsec))
(flagToList . fmap prettyShow))
, option [] ["version"]
"Initial version of the package."
IT.version (\v flags -> flags { IT.version = v })
(reqArg "VERSION" (readP_to_E ("Cannot parse package version: "++)
(toFlag `fmap` parse))
(flagToList . fmap display))
(reqArg "VERSION" (parsecToReadE ("Cannot parse package version: "++)
(toFlag `fmap` parsec))
(flagToList . fmap prettyShow))
, option [] ["cabal-version"]
"Version of the Cabal specification."
IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v })
(reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal specification version: "++)
(toFlag `fmap` parse))
(flagToList . fmap display))
(reqArg "CABALSPECVERSION" (parsecToReadE ("Cannot parse Cabal specification version: "++)
(fmap (toFlag . getSpecVersion) parsec))
(flagToList . fmap (prettyShow . SpecVersion)))
, option ['l'] ["license"]
"Project license."
IT.license (\v flags -> flags { IT.license = v })
(reqArg "LICENSE" (readP_to_E ("Cannot parse license: "++)
(toFlag `fmap` parse))
(flagToList . fmap display))
(reqArg "LICENSE" (parsecToReadE ("Cannot parse license: "++)
(toFlag `fmap` parsec))
(flagToList . fmap prettyShow))
, option ['a'] ["author"]
"Name of the project's author."
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment