diff --git a/Distribution/Client/CmdBuild.hs b/Distribution/Client/CmdBuild.hs --- a/Distribution/Client/CmdBuild.hs +++ b/Distribution/Client/CmdBuild.hs @@ -14,13 +14,15 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages +import Distribution.Compat.Semigroup ((<>)) import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , liftOptions, yesNoOpt ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags, fromFlagOrDefault ) + ( HaddockFlags, Flag(..), toFlag, fromFlag, fromFlagOrDefault ) import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) + ( CommandUI(..), usageAlternatives, option ) import Distribution.Verbosity ( Verbosity, normal ) import Distribution.Simple.Utils @@ -29,8 +31,8 @@ import qualified Data.Map as Map -buildCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -buildCommand = Client.installCommand { +buildCommand :: CommandUI (BuildFlags, (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)) +buildCommand = CommandUI { commandName = "new-build", commandSynopsis = "Compile targets within the project.", commandUsage = usageAlternatives "new-build" [ "[TARGETS] [FLAGS]" ], @@ -59,10 +61,33 @@ ++ " " ++ pname ++ " new-build cname --enable-profiling\n" ++ " Build the component in profiling mode (including dependencies as needed)\n\n" - ++ cmdCommonHelpTextNewBuildBeta - } + ++ cmdCommonHelpTextNewBuildBeta, + commandDefaultFlags = + (defaultBuildFlags, commandDefaultFlags Client.installCommand), + commandOptions = \ showOrParseArgs -> + liftOptions snd setSnd + (commandOptions Client.installCommand showOrParseArgs) ++ + liftOptions fst setFst + [ option [] ["only-configure"] + "Instead of performing a full build just run the configure step" + buildOnlyConfigure (\v flags -> flags { buildOnlyConfigure = v }) + (yesNoOpt showOrParseArgs) + ] + } + where + setFst a (_,b) = (a,b) + setSnd b (a,_) = (a,b) +data BuildFlags = BuildFlags + { buildOnlyConfigure :: Flag Bool + } + +defaultBuildFlags :: BuildFlags +defaultBuildFlags = BuildFlags + { buildOnlyConfigure = toFlag False + } + -- | The @build@ command does a lot. It brings the install plan up to date, -- selects that part of the plan needed by the given or implicit targets and -- then executes the plan. @@ -70,10 +95,17 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -buildAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +buildAction :: (BuildFlags, (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)) -> [String] -> GlobalFlags -> IO () -buildAction (configFlags, configExFlags, installFlags, haddockFlags) +buildAction (buildFlags, + (configFlags, configExFlags, installFlags, haddockFlags)) targetStrings globalFlags = do + -- TODO: This flags defaults business is ugly + let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags + <> buildOnlyConfigure buildFlags) + targetAction + | onlyConfigure = TargetActionConfigure + | otherwise = TargetActionBuild baseCtx <- establishProjectBaseContext verbosity cliConfig @@ -95,7 +127,7 @@ targetSelectors let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionBuild + targetAction targets elaboratedPlan elaboratedPlan'' <- @@ -192,4 +224,3 @@ reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a reportCannotPruneDependencies verbosity = die' verbosity . renderCannotPruneDependencies - diff --git a/Distribution/Client/CmdClean.hs b/Distribution/Client/CmdClean.hs --- a/Distribution/Client/CmdClean.hs +++ b/Distribution/Client/CmdClean.hs @@ -22,46 +22,52 @@ import Distribution.Verbosity ( Verbosity, normal ) +import Control.Monad + ( mapM_ ) import Control.Exception ( throwIO ) import System.Directory - ( removeDirectoryRecursive, doesDirectoryExist ) + ( removeDirectoryRecursive, removeFile + , doesDirectoryExist, getDirectoryContents ) +import System.FilePath + ( () ) data CleanFlags = CleanFlags - { cleanSaveConfig :: Flag Bool - , cleanVerbosity :: Flag Verbosity - , cleanDistDir :: Flag FilePath + { cleanSaveConfig :: Flag Bool + , cleanVerbosity :: Flag Verbosity + , cleanDistDir :: Flag FilePath , cleanProjectFile :: Flag FilePath } deriving (Eq) defaultCleanFlags :: CleanFlags defaultCleanFlags = CleanFlags - { cleanSaveConfig = toFlag False - , cleanVerbosity = toFlag normal - , cleanDistDir = NoFlag + { cleanSaveConfig = toFlag False + , cleanVerbosity = toFlag normal + , cleanDistDir = NoFlag , cleanProjectFile = mempty } cleanCommand :: CommandUI CleanFlags cleanCommand = CommandUI - { commandName = "new-clean" - , commandSynopsis = "Clean the package store and remove temporary files." - , commandUsage = \pname -> + { commandName = "new-clean" + , commandSynopsis = "Clean the package store and remove temporary files." + , commandUsage = \pname -> "Usage: " ++ pname ++ " new-clean [FLAGS]\n" , commandDescription = Just $ \_ -> wrapText $ "Removes all temporary files created during the building process " ++ "(.hi, .o, preprocessed sources, etc.) and also empties out the " ++ "local caches (by default).\n\n" - , commandNotes = Nothing + , commandNotes = Nothing , commandDefaultFlags = defaultCleanFlags - , commandOptions = \showOrParseArgs -> + , commandOptions = \showOrParseArgs -> [ optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) , optionDistPref cleanDistDir (\dd flags -> flags { cleanDistDir = dd }) showOrParseArgs , option [] ["project-file"] - "Set the name of the cabal.project file to search for in parent directories" + ("Set the name of the cabal.project file" + ++ " to search for in parent directories") cleanProjectFile (\pf flags -> flags {cleanProjectFile = pf}) (reqArg "FILE" (succeedReadE Flag) flagToList) , option ['s'] ["save-config"] @@ -73,13 +79,14 @@ cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO () cleanAction CleanFlags{..} extraArgs _ = do - let verbosity = fromFlagOrDefault normal cleanVerbosity - saveConfig = fromFlagOrDefault False cleanSaveConfig + let verbosity = fromFlagOrDefault normal cleanVerbosity + saveConfig = fromFlagOrDefault False cleanSaveConfig mdistDirectory = flagToMaybe cleanDistDir - mprojectFile = flagToMaybe cleanProjectFile + mprojectFile = flagToMaybe cleanProjectFile unless (null extraArgs) $ - die' verbosity $ "'clean' doesn't take any extra arguments: " ++ unwords extraArgs + die' verbosity $ "'clean' doesn't take any extra arguments: " + ++ unwords extraArgs projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile @@ -88,20 +95,21 @@ if saveConfig then do let buildRoot = distBuildRootDirectory distLayout - unpackedSrcRoot = distUnpackedSrcRootDirectory distLayout buildRootExists <- doesDirectoryExist buildRoot - unpackedSrcRootExists <- doesDirectoryExist unpackedSrcRoot when buildRootExists $ do info verbosity ("Deleting build root (" ++ buildRoot ++ ")") handleDoesNotExist () $ removeDirectoryRecursive buildRoot - - when unpackedSrcRootExists $ do - info verbosity ("Deleting unpacked source root (" ++ unpackedSrcRoot ++ ")") - handleDoesNotExist () $ removeDirectoryRecursive unpackedSrcRoot else do let distRoot = distDirectory distLayout info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")") handleDoesNotExist () $ removeDirectoryRecursive distRoot + + removeEnvFiles (distProjectRootDirectory distLayout) + +removeEnvFiles :: FilePath -> IO () +removeEnvFiles dir = + (mapM_ (removeFile . (dir )) . filter ((".ghc.environment" ==) . take 16)) + =<< getDirectoryContents dir diff --git a/Distribution/Client/CmdExec.hs b/Distribution/Client/CmdExec.hs --- a/Distribution/Client/CmdExec.hs +++ b/Distribution/Client/CmdExec.hs @@ -27,6 +27,7 @@ , GlobalFlags , InstallFlags ) +import qualified Distribution.Client.Setup as Client import Distribution.Client.ProjectOrchestration ( ProjectBuildContext(..) , runProjectPreBuildPhase @@ -86,8 +87,6 @@ , normal ) -import qualified Distribution.Client.CmdBuild as CmdBuild - import Prelude () import Distribution.Client.Compat.Prelude @@ -116,8 +115,8 @@ ++ " to choose an appropriate version of ghc and to include any" ++ " ghc-specific flags requested." , commandNotes = Nothing - , commandOptions = commandOptions CmdBuild.buildCommand - , commandDefaultFlags = commandDefaultFlags CmdBuild.buildCommand + , commandOptions = commandOptions Client.installCommand + , commandDefaultFlags = commandDefaultFlags Client.installCommand } execAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) diff --git a/Distribution/Client/CmdInstall.hs b/Distribution/Client/CmdInstall.hs --- a/Distribution/Client/CmdInstall.hs +++ b/Distribution/Client/CmdInstall.hs @@ -26,15 +26,16 @@ import Distribution.Client.CmdSdist import Distribution.Client.Setup - ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags + ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..) , configureExOptions, installOptions, liftOptions ) import Distribution.Solver.Types.ConstraintSource ( ConstraintSource(..) ) import Distribution.Client.Types - ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage ) + ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage + , SourcePackageDb(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Package - ( Package(..), PackageName, mkPackageName ) + ( Package(..), PackageName, mkPackageName, unPackageName ) import Distribution.Types.PackageId ( PackageIdentifier(..) ) import Distribution.Client.ProjectConfig.Types @@ -50,8 +51,9 @@ ( ProgramSearchPathEntry(..) ) import Distribution.Client.Config ( getCabalDir ) -import Distribution.Simple.PackageIndex - ( InstalledPackageIndex, lookupPackageName, lookupUnitId ) +import qualified Distribution.Simple.PackageIndex as PI +import Distribution.Solver.Types.PackageIndex + ( lookupPackageName, searchByName ) import Distribution.Types.InstalledPackageInfo ( InstalledPackageInfo(..) ) import Distribution.Types.Version @@ -73,14 +75,14 @@ import Distribution.Client.RebuildMonad ( runRebuild ) import Distribution.Client.InstallSymlink - ( symlinkBinary ) + ( OverwritePolicy(..), symlinkBinary ) import Distribution.Simple.Setup - ( Flag(Flag), HaddockFlags, fromFlagOrDefault, flagToMaybe, toFlag + ( Flag(..), HaddockFlags, fromFlagOrDefault, flagToMaybe, toFlag , trueArg, configureOptions, haddockOptions, flagToList ) import Distribution.Solver.Types.SourcePackage ( SourcePackage(..) ) import Distribution.ReadE - ( succeedReadE ) + ( ReadE(..), succeedReadE ) import Distribution.Simple.Command ( CommandUI(..), ShowOrParseArgs(..), OptionField(..) , option, usageAlternatives, reqArg ) @@ -107,6 +109,8 @@ ( writeFileAtomic ) import Distribution.Text ( simpleParse ) +import Distribution.Pretty + ( prettyShow ) import Control.Exception ( catch ) @@ -114,7 +118,7 @@ ( mapM, mapM_ ) import qualified Data.ByteString.Lazy.Char8 as BS import Data.Either - ( partitionEithers ) + ( partitionEithers, isLeft ) import Data.Ord ( comparing, Down(..) ) import qualified Data.Map as Map @@ -129,12 +133,14 @@ data NewInstallFlags = NewInstallFlags { ninstInstallLibs :: Flag Bool , ninstEnvironmentPath :: Flag FilePath + , ninstOverwritePolicy :: Flag OverwritePolicy } defaultNewInstallFlags :: NewInstallFlags defaultNewInstallFlags = NewInstallFlags { ninstInstallLibs = toFlag False , ninstEnvironmentPath = mempty + , ninstOverwritePolicy = toFlag NeverOverwrite } newInstallOptions :: ShowOrParseArgs -> [OptionField NewInstallFlags] @@ -147,7 +153,22 @@ "Set the environment file that may be modified." ninstEnvironmentPath (\pf flags -> flags { ninstEnvironmentPath = pf }) (reqArg "ENV" (succeedReadE Flag) flagToList) + , option [] ["overwrite-policy"] + "How to handle already existing symlinks." + ninstOverwritePolicy (\v flags -> flags { ninstOverwritePolicy = v }) + $ reqArg + "always|never" + readOverwritePolicyFlag + showOverwritePolicyFlag ] + where + readOverwritePolicyFlag = ReadE $ \case + "always" -> Right $ Flag AlwaysOverwrite + "never" -> Right $ Flag NeverOverwrite + policy -> Left $ "'" <> policy <> "' isn't a valid overwrite policy" + showOverwritePolicyFlag (Flag AlwaysOverwrite) = ["always"] + showOverwritePolicyFlag (Flag NeverOverwrite) = ["never"] + showOverwritePolicyFlag NoFlag = [] installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags , HaddockFlags, NewInstallFlags @@ -194,9 +215,9 @@ . optionName) $ installOptions showOrParseArgs) ++ liftOptions get4 set4 - -- hide "target-package-db" flag from the - -- install options. - (filter ((`notElem` ["v", "verbose"]) + -- hide "verbose" and "builddir" flags from the + -- haddock options. + (filter ((`notElem` ["v", "verbose", "builddir"]) . optionName) $ haddockOptions showOrParseArgs) ++ liftOptions get5 set5 (newInstallOptions showOrParseArgs) @@ -289,6 +310,18 @@ TargetProblemCommon (TargetAvailableInIndex name) -> Right name err -> Left err + -- report incorrect case for known package. + for_ errs' $ \case + TargetProblemCommon (TargetNotInProject hn) -> + case searchByName (packageIndex pkgDb) (unPackageName hn) of + [] -> return () + xs -> die' verbosity . concat $ + [ "Unknown package \"", unPackageName hn, "\". " + , "Did you mean any of the following?\n" + , unlines (("- " ++) . unPackageName . fst <$> xs) + ] + _ -> return () + when (not . null $ errs') $ reportTargetProblems verbosity errs' let @@ -356,6 +389,42 @@ | Just (pkg :: PackageId) <- simpleParse pkgName = return pkg | otherwise = die' verbosity ("Invalid package ID: " ++ pkgName) packageIds <- mapM parsePkg targetStrings + + cabalDir <- getCabalDir + let + projectConfig = globalConfig <> cliConfig + + ProjectConfigBuildOnly { + projectConfigLogsDir + } = projectConfigBuildOnly projectConfig + + ProjectConfigShared { + projectConfigStoreDir + } = projectConfigShared projectConfig + + mlogsDir = flagToMaybe projectConfigLogsDir + mstoreDir = flagToMaybe projectConfigStoreDir + cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + + buildSettings = resolveBuildTimeSettings + verbosity cabalDirLayout + projectConfig + + SourcePackageDb { packageIndex } <- projectConfigWithBuilderRepoContext + verbosity buildSettings + (getSourcePackages verbosity) + + for_ targetStrings $ \case + name + | null (lookupPackageName packageIndex (mkPackageName name)) + , xs@(_:_) <- searchByName packageIndex name -> + die' verbosity . concat $ + [ "Unknown package \"", name, "\". " + , "Did you mean any of the following?\n" + , unlines (("- " ++) . unPackageName . fst <$> xs) + ] + _ -> return () + let packageSpecifiers = flip fmap packageIds $ \case PackageIdentifier{..} @@ -363,7 +432,7 @@ | otherwise -> NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)] packageTargets = flip TargetPackageNamed Nothing . pkgName <$> packageIds - return (packageSpecifiers, packageTargets, globalConfig <> cliConfig) + return (packageSpecifiers, packageTargets, projectConfig) (specs, selectors, config) <- withProjectOrGlobalConfig verbosity globalConfigFlag withProject withoutProject @@ -437,9 +506,9 @@ " is unparsable. Libraries cannot be installed.") >> return [] else return [] - cabalDir <- getCabalDir + cabalDir <- getCabalDir + mstoreDir <- sequenceA $ makeAbsolute <$> flagToMaybe (globalStoreDir globalFlags) let - mstoreDir = flagToMaybe (globalStoreDir globalFlags) mlogsDir = flagToMaybe (globalLogsDir globalFlags) cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir packageDbs = storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId @@ -492,15 +561,21 @@ printPlan verbosity baseCtx buildCtx buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + -- Temporary fix for #5641 + when (any isLeft buildOutcomes) $ + warn verbosity $ "Some package(s) failed to build. " + <> "Try rerunning with -j1 if you can't see the error." + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes let + dryRun = buildSettingDryRun $ buildSettings baseCtx mkPkgBinDir = ( "bin") . storePackageDirectory (cabalStoreDirLayout $ cabalDirLayout baseCtx) compilerId installLibs = fromFlagOrDefault False (ninstInstallLibs newInstallFlags) - when (not installLibs) $ do + when (not installLibs && not dryRun) $ do -- If there are exes, symlink them let symlinkBindirUnknown = "symlink-bindir is not defined. Set it in your cabal config file " @@ -511,11 +586,15 @@ $ projectConfigBuildOnly $ projectConfig $ baseCtx createDirectoryIfMissingVerbose verbosity False symlinkBindir - traverse_ (symlinkBuiltPackage verbosity mkPkgBinDir symlinkBindir) - $ Map.toList $ targetsMap buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + warnIfNoExes verbosity buildCtx + let + doSymlink = symlinkBuiltPackage + verbosity + overwritePolicy + mkPkgBinDir symlinkBindir + in traverse_ doSymlink $ Map.toList $ targetsMap buildCtx - when installLibs $ + when (installLibs && not dryRun) $ if supportsPkgEnvFiles then do -- Why do we get it again? If we updated a globalPackage then we need @@ -523,7 +602,7 @@ installedIndex' <- getInstalledPackages verbosity compiler packageDbs progDb' let getLatest = fmap (head . snd) . take 1 . sortBy (comparing (Down . fst)) - . lookupPackageName installedIndex' + . PI.lookupPackageName installedIndex' globalLatest = concat (getLatest <$> globalPackages) baseEntries = @@ -548,7 +627,26 @@ globalFlags configFlags' configExFlags installFlags haddockFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) + overwritePolicy = fromFlagOrDefault NeverOverwrite + $ ninstOverwritePolicy newInstallFlags +warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO () +warnIfNoExes verbosity buildCtx = + when noExes $ + warn verbosity $ "You asked to install executables, " + <> "but there are no executables in " + <> plural (listPlural selectors) "target" "targets" <> ": " + <> intercalate ", " (showTargetSelector <$> selectors) <> ". " + <> "Perhaps you want to use --lib " + <> "to install libraries instead." + where + targets = concat $ Map.elems $ targetsMap buildCtx + components = fst <$> targets + selectors = concatMap snd targets + noExes = null $ catMaybes $ exeMaybe <$> components + exeMaybe (ComponentTarget (CExeName exe) _) = Just exe + exeMaybe _ = Nothing + globalPackages :: [PackageName] globalPackages = mkPackageName <$> [ "ghc", "hoopl", "bytestring", "unix", "base", "time", "hpc", "filepath" @@ -558,12 +656,12 @@ , "bin-package-db" ] -environmentFileToSpecifiers :: InstalledPackageIndex -> [GhcEnvironmentFileEntry] +environmentFileToSpecifiers :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry] -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]) environmentFileToSpecifiers ipi = foldMap $ \case (GhcEnvFilePackageId unitId) | Just InstalledPackageInfo{ sourcePackageId = PackageIdentifier{..}, installedUnitId } - <- lookupUnitId ipi unitId + <- PI.lookupUnitId ipi unitId , let pkgSpec = NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)] -> if pkgName `elem` globalPackages then ([pkgSpec], []) @@ -579,24 +677,43 @@ -- | Symlink every exe from a package from the store to a given location symlinkBuiltPackage :: Verbosity + -> OverwritePolicy -- ^ Whether to overwrite existing files -> (UnitId -> FilePath) -- ^ A function to get an UnitId's -- store directory -> FilePath -- ^ Where to put the symlink -> ( UnitId , [(ComponentTarget, [TargetSelector])] ) -> IO () -symlinkBuiltPackage verbosity mkSourceBinDir destDir (pkg, components) = - traverse_ (symlinkBuiltExe verbosity (mkSourceBinDir pkg) destDir) exes +symlinkBuiltPackage verbosity overwritePolicy + mkSourceBinDir destDir + (pkg, components) = + traverse_ symlinkAndWarn exes where exes = catMaybes $ (exeMaybe . fst) <$> components exeMaybe (ComponentTarget (CExeName exe) _) = Just exe exeMaybe _ = Nothing + symlinkAndWarn exe = do + success <- symlinkBuiltExe + verbosity overwritePolicy + (mkSourceBinDir pkg) destDir exe + let errorMessage = case overwritePolicy of + NeverOverwrite -> + "Path '" <> (destDir prettyShow exe) <> "' already exists. " + <> "Use --overwrite-policy=always to overwrite." + -- This shouldn't even be possible, but we keep it in case + -- symlinking logic changes + AlwaysOverwrite -> "Symlinking '" <> prettyShow exe <> "' failed." + unless success $ die' verbosity errorMessage -- | Symlink a specific exe. -symlinkBuiltExe :: Verbosity -> FilePath -> FilePath -> UnqualComponentName -> IO Bool -symlinkBuiltExe verbosity sourceDir destDir exe = do - notice verbosity $ "Symlinking " ++ unUnqualComponentName exe +symlinkBuiltExe :: Verbosity -> OverwritePolicy + -> FilePath -> FilePath + -> UnqualComponentName + -> IO Bool +symlinkBuiltExe verbosity overwritePolicy sourceDir destDir exe = do + notice verbosity $ "Symlinking '" <> prettyShow exe <> "'" symlinkBinary + overwritePolicy destDir sourceDir exe diff --git a/Distribution/Client/CmdRepl.hs b/Distribution/Client/CmdRepl.hs --- a/Distribution/Client/CmdRepl.hs +++ b/Distribution/Client/CmdRepl.hs @@ -35,6 +35,8 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedSharedConfig(..), ElaboratedInstallPlan ) +import Distribution.Client.ProjectPlanning.Types + ( elabOrderExeDependencies ) import Distribution.Client.RebuildMonad ( runRebuild ) import Distribution.Client.Setup @@ -407,14 +409,20 @@ generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> ReplFlags generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags where + exeDeps :: [UnitId] + exeDeps = + foldMap + (InstallPlan.foldPlanPackage (const []) elabOrderExeDependencies) + (InstallPlan.dependencyClosure elaboratedPlan [ociUnitId]) + deps, deps', trans, trans' :: [UnitId] flags :: ReplFlags deps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId deps' = deps \\ ociOriginalDeps trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps' trans' = trans \\ ociOriginalDeps - flags = ("-package-id " ++) . prettyShow <$> - if includeTransitive then trans' else deps' + flags = fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps) + $ if includeTransitive then trans' else deps' -- | This defines what a 'TargetSelector' means for the @repl@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/Distribution/Client/CmdRun.hs b/Distribution/Client/CmdRun.hs --- a/Distribution/Client/CmdRun.hs +++ b/Distribution/Client/CmdRun.hs @@ -286,7 +286,9 @@ emptyProgramInvocation { progInvokePath = exePath, progInvokeArgs = args, - progInvokeEnv = dataDirsEnvironmentForPlan elaboratedPlan + progInvokeEnv = dataDirsEnvironmentForPlan + (distDirLayout baseCtx) + elaboratedPlan } handleDoesNotExist () (removeDirectoryRecursive tempDir) diff --git a/Distribution/Client/CmdSdist.hs b/Distribution/Client/CmdSdist.hs --- a/Distribution/Client/CmdSdist.hs +++ b/Distribution/Client/CmdSdist.hs @@ -29,6 +29,9 @@ import Distribution.Client.ProjectConfig ( findProjectRoot, readProjectConfig ) +import Distribution.Compat.Semigroup + ((<>)) + import Distribution.Package ( Package(packageId) ) import Distribution.PackageDescription.Configuration @@ -217,78 +220,102 @@ packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO () packageToSdist verbosity projectRootDir format outputFile pkg = do - dir <- case packageSource pkg of - LocalUnpackedPackage path -> return path - _ -> die' verbosity "The impossible happened: a local package isn't local" - oldPwd <- getCurrentDirectory - setCurrentDirectory dir - - let norm flag = fmap ((flag, ) . normalise) - (norm NoExec -> nonexec, norm Exec -> exec) <- - listPackageSources verbosity (flattenPackageDescription $ packageDescription pkg) knownSuffixHandlers + let death = die' verbosity ("The impossible happened: a local package isn't local" <> (show pkg)) + dir0 <- case packageSource pkg of + LocalUnpackedPackage path -> pure (Right path) + RemoteSourceRepoPackage _ (Just path) -> pure (Right path) + RemoteSourceRepoPackage {} -> death + LocalTarballPackage tgz -> pure (Left tgz) + RemoteTarballPackage _ (Just tgz) -> pure (Left tgz) + RemoteTarballPackage {} -> death + RepoTarballPackage {} -> death let write = if outputFile == "-" then putStr . withOutputMarker verbosity . BSL.unpack else BSL.writeFile outputFile - files = nub . sortOn snd $ nonexec ++ exec - case format of - SourceList nulSep -> do - let prefix = makeRelative projectRootDir dir - write (BSL.pack . (++ [nulSep]) . intercalate [nulSep] . fmap ((prefix ) . snd) $ files) + case dir0 of + Left tgz -> do + case format of + Archive TargzFormat -> do + write =<< BSL.readFile tgz when (outputFile /= "-") $ - notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n" - Archive TargzFormat -> do - let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) () - entriesM = do - let prefix = prettyShow (packageId pkg) - modify (Set.insert prefix) - case Tar.toTarPath True prefix of - Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) - Right path -> tell [Tar.directoryEntry path] + notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" + _ -> die' verbosity ("cannot convert tarball package to " ++ show format) - forM_ files $ \(perm, file) -> do - let fileDir = takeDirectory (prefix file) - perm' = case perm of - Exec -> Tar.executableFilePermissions - NoExec -> Tar.ordinaryFilePermissions - needsEntry <- gets (Set.notMember fileDir) + Right dir -> do + oldPwd <- getCurrentDirectory + setCurrentDirectory dir - when needsEntry $ do - modify (Set.insert fileDir) - case Tar.toTarPath True fileDir of - Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) - Right path -> tell [Tar.directoryEntry path] - - contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ file - case Tar.toTarPath False (prefix file) of + let norm flag = fmap ((flag, ) . normalise) + (norm NoExec -> nonexec, norm Exec -> exec) <- + listPackageSources verbosity (flattenPackageDescription $ packageDescription pkg) knownSuffixHandlers + + let files = nub . sortOn snd $ nonexec ++ exec + + case format of + SourceList nulSep -> do + let prefix = makeRelative projectRootDir dir + write (BSL.pack . (++ [nulSep]) . intercalate [nulSep] . fmap ((prefix ) . snd) $ files) + when (outputFile /= "-") $ + notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n" + Archive TargzFormat -> do + let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) () + entriesM = do + let prefix = prettyShow (packageId pkg) + modify (Set.insert prefix) + case Tar.toTarPath True prefix of Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) - Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = perm' }] - - entries <- execWriterT (evalStateT entriesM mempty) - let -- Pretend our GZip file is made on Unix. - normalize bs = BSL.concat [first, "\x03", rest'] - where - (first, rest) = BSL.splitAt 9 bs - rest' = BSL.tail rest - write . normalize . GZip.compress . Tar.write $ entries - when (outputFile /= "-") $ - notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" - Archive ZipFormat -> do - let prefix = prettyShow (packageId pkg) - entries <- forM files $ \(perm, file) -> do - let perm' = case perm of - -- -rwxr-xr-x - Exec -> 0o010755 `shiftL` 16 - -- -rw-r--r-- - NoExec -> 0o010644 `shiftL` 16 - contents <- BSL.readFile file - return $ (Zip.toEntry (prefix file) 0 contents) { Zip.eExternalFileAttributes = perm' } - let archive = foldr Zip.addEntryToArchive Zip.emptyArchive entries - write (Zip.fromArchive archive) - when (outputFile /= "-") $ - notice verbosity $ "Wrote zip sdist to " ++ outputFile ++ "\n" - setCurrentDirectory oldPwd + Right path -> tell [Tar.directoryEntry path] + + forM_ files $ \(perm, file) -> do + let fileDir = takeDirectory (prefix file) + perm' = case perm of + Exec -> Tar.executableFilePermissions + NoExec -> Tar.ordinaryFilePermissions + needsEntry <- gets (Set.notMember fileDir) + + when needsEntry $ do + modify (Set.insert fileDir) + case Tar.toTarPath True fileDir of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [Tar.directoryEntry path] + + contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ file + case Tar.toTarPath False (prefix file) of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = perm' }] + + entries <- execWriterT (evalStateT entriesM mempty) + let -- Pretend our GZip file is made on Unix. + normalize bs = BSL.concat [first, "\x03", rest'] + where + (first, rest) = BSL.splitAt 9 bs + rest' = BSL.tail rest + -- The Unix epoch, which is the default value, is + -- unsuitable because it causes unpacking problems on + -- Windows; we need a post-1980 date. One gigasecond + -- after the epoch is during 2001-09-09, so that does + -- nicely. See #5596. + setModTime entry = entry { Tar.entryTime = 1000000000 } + write . normalize . GZip.compress . Tar.write $ fmap setModTime entries + when (outputFile /= "-") $ + notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" + Archive ZipFormat -> do + let prefix = prettyShow (packageId pkg) + entries <- forM files $ \(perm, file) -> do + let perm' = case perm of + -- -rwxr-xr-x + Exec -> 0o010755 `shiftL` 16 + -- -rw-r--r-- + NoExec -> 0o010644 `shiftL` 16 + contents <- BSL.readFile file + return $ (Zip.toEntry (prefix file) 0 contents) { Zip.eExternalFileAttributes = perm' } + let archive = foldr Zip.addEntryToArchive Zip.emptyArchive entries + write (Zip.fromArchive archive) + when (outputFile /= "-") $ + notice verbosity $ "Wrote zip sdist to " ++ outputFile ++ "\n" + setCurrentDirectory oldPwd -- diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs --- a/Distribution/Client/Config.hs +++ b/Distribution/Client/Config.hs @@ -359,7 +359,9 @@ configPreferences = lastNonEmpty configPreferences, configSolver = combine configSolver, configAllowNewer = combineMonoid savedConfigureExFlags configAllowNewer, - configAllowOlder = combineMonoid savedConfigureExFlags configAllowOlder + configAllowOlder = combineMonoid savedConfigureExFlags configAllowOlder, + configWriteGhcEnvironmentFilesPolicy + = combine configWriteGhcEnvironmentFilesPolicy } where combine = combine' savedConfigureExFlags diff --git a/Distribution/Client/DistDirLayout.hs b/Distribution/Client/DistDirLayout.hs --- a/Distribution/Client/DistDirLayout.hs +++ b/Distribution/Client/DistDirLayout.hs @@ -273,7 +273,7 @@ mkCabalDirLayout cabalDir Nothing Nothing mkCabalDirLayout :: FilePath -- ^ Cabal directory - -> Maybe FilePath -- ^ Store directory + -> Maybe FilePath -- ^ Store directory. Must be absolute -> Maybe FilePath -- ^ Log directory -> CabalDirLayout mkCabalDirLayout cabalDir mstoreDir mlogDir = diff --git a/Distribution/Client/Init.hs b/Distribution/Client/Init.hs --- a/Distribution/Client/Init.hs +++ b/Distribution/Client/Init.hs @@ -17,7 +17,6 @@ -- * Commands initCabal - , pvpize , incVersion ) where @@ -48,7 +47,7 @@ import Text.PrettyPrint hiding (mode, cat) import Distribution.Version - ( Version, mkVersion, alterVersion + ( Version, mkVersion, alterVersion, versionNumbers, majorBoundVersion , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange ) import Distribution.Verbosity ( Verbosity ) @@ -70,7 +69,8 @@ scanForModules, neededBuildPrograms ) import Distribution.License - ( License(..), knownLicenses ) + ( License(..), knownLicenses, licenseToSPDX ) +import qualified Distribution.SPDX as SPDX import Distribution.ReadE ( runReadE, readP_to_E ) @@ -88,6 +88,10 @@ ( InstalledPackageIndex, moduleNameIndex ) import Distribution.Text ( display, Text(..) ) +import Distribution.Pretty + ( prettyShow ) +import Distribution.Parsec.Class + ( eitherParsec ) import Distribution.Solver.Types.PackageIndex ( elemByPackageName ) @@ -134,7 +138,8 @@ -- user. extendFlags :: InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags extendFlags pkgIx sourcePkgDb = - getPackageName sourcePkgDb + getCabalVersion + >=> getPackageName sourcePkgDb >=> getVersion >=> getLicense >=> getAuthorInfo @@ -162,6 +167,30 @@ maybeToFlag :: Maybe a -> Flag a 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 which version of the cabal spec to use. +getCabalVersion :: InitFlags -> IO InitFlags +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]] + (Just defaultCabalVersion) displayCabalVersion False) + ?>> return (Just defaultCabalVersion) + + return $ flags { cabalVersion = maybeToFlag cabVer } + + -- | 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 -- using an existing package name. @@ -209,16 +238,26 @@ lic <- return (flagToMaybe $ license flags) ?>> fmap (fmap (either UnknownLicense id)) (maybePrompt flags - (promptList "Please choose a license" listedLicenses (Just BSD3) display True)) + (promptList "Please choose a license" listedLicenses + (Just BSD3) displayLicense True)) - if isLicenseInvalid lic - then putStrLn promptInvalidOtherLicenseMsg >> getLicense flags - else return $ flags { license = maybeToFlag lic } + case checkLicenseInvalid lic of + Just msg -> putStrLn msg >> getLicense flags + Nothing -> return $ flags { license = maybeToFlag lic } where - isLicenseInvalid (Just (UnknownLicense t)) = any (not . isAlphaNum) t - isLicenseInvalid _ = False + 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). " ++ @@ -228,6 +267,8 @@ knownLicenses \\ [GPL Nothing, LGPL Nothing, AGPL Nothing , Apache Nothing, OtherLicense] + needSpdx = maybe False (>= mkVersion [2,2]) $ flagToMaybe (cabalVersion flags) + -- | The author's name and email. Prompt, or try to guess from an existing -- darcs repo. getAuthorInfo :: InitFlags -> IO InitFlags @@ -480,24 +521,31 @@ where pkgGroups = groupBy ((==) `on` P.pkgName) (map P.packageId ps) + desugar = maybe True (< mkVersion [2]) $ flagToMaybe (cabalVersion flags) + -- Given a list of available versions of the same package, pick a dependency. toDep :: [P.PackageIdentifier] -> IO P.Dependency -- If only one version, easy. We change e.g. 0.4.2 into 0.4.* - toDep [pid] = return $ P.Dependency (P.pkgName pid) (pvpize . P.pkgVersion $ pid) + toDep [pid] = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) -- Otherwise, choose the latest version and issue a warning. toDep pids = do message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.") return $ P.Dependency (P.pkgName . head $ pids) - (pvpize . maximum . map P.pkgVersion $ pids) + (pvpize desugar . maximum . map P.pkgVersion $ pids) -- | Given a version, return an API-compatible (according to PVP) version range. -- --- Example: @0.4.1@ produces the version range @>= 0.4 && < 0.5@ (which is the +-- If the boolean argument denotes whether to use a desugared +-- representation (if 'True') or the new-style @^>=@-form (if +-- 'False'). +-- +-- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the -- same as @0.4.*@). -pvpize :: Version -> VersionRange -pvpize v = orLaterVersion v' +pvpize :: Bool -> Version -> VersionRange +pvpize False v = majorBoundVersion v +pvpize True v = orLaterVersion v' `intersectVersionRanges` earlierVersion (incVersion 1 v') where v' = alterVersion (take 2) v @@ -804,9 +852,16 @@ 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 minimal c /= Flag True - then showComment (Just $ "Initial " ++ fileName ++ " generated by cabal " - ++ "init. For further documentation, see " + then showComment (Just $ "Initial package description '" ++ fileName ++ "' generated " + ++ "by 'cabal init'. For further documentation, see " ++ "http://haskell.org/cabal/users-guide/") $$ text "" else empty) @@ -816,7 +871,7 @@ True , field "version" (version c) - (Just $ "The package version. See the Haskell package versioning policy (PVP) for standards guiding when and how versions should be incremented.\nhttps://wiki.haskell.org/Package_versioning_policy\n" + (Just $ "The package version. See the Haskell package versioning policy (PVP) for standards guiding when and how versions should be incremented.\nhttps://pvp.haskell.org\n" ++ "PVP summary: +-+------- breaking API changes\n" ++ " | | +----- non-breaking API additions\n" ++ " | | | +--- code changes with no API change") @@ -836,9 +891,9 @@ , fieldS "bug-reports" NoFlag (Just "A URL where users can report bugs.") - False + True - , field "license" (license c) + , fieldS "license" licenseStr (Just "The license under which the package is released.") True @@ -866,18 +921,14 @@ Nothing True - , fieldS "build-type" (Flag "Simple") + , fieldS "build-type" (if specVer >= mkVersion [2,2] then NoFlag else Flag "Simple") Nothing - True + False , fieldS "extra-source-files" (listFieldS (extraSrc c)) (Just "Extra files to be distributed with the package, such as examples or a README.") True - , field "cabal-version" (Flag $ orLaterVersion (mkVersion [1,10])) - (Just "Constraint on the version of Cabal needed to build this package.") - False - , case packageType c of Flag Executable -> executableStanza Flag Library -> libraryStanza @@ -885,6 +936,14 @@ _ -> empty ] 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) + generateBuildInfo :: BuildType -> InitFlags -> Doc generateBuildInfo buildType c' = vcat [ fieldS "other-modules" (listField (otherModules c')) diff --git a/Distribution/Client/Init/Types.hs b/Distribution/Client/Init/Types.hs --- a/Distribution/Client/Init/Types.hs +++ b/Distribution/Client/Init/Types.hs @@ -47,7 +47,7 @@ , packageName :: Flag P.PackageName , version :: Flag Version - , cabalVersion :: Flag VersionRange + , cabalVersion :: Flag Version , license :: Flag License , author :: Flag String , email :: Flag String @@ -68,6 +68,8 @@ , dependencies :: Maybe [P.Dependency] , sourceDirs :: Maybe [String] , buildTools :: Maybe [String] + + , initHcPath :: Flag FilePath , initVerbosity :: Flag Verbosity , overwrite :: Flag Bool diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -96,7 +96,7 @@ import qualified Distribution.Client.BuildReports.Storage as BuildReports ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure ) import qualified Distribution.Client.InstallSymlink as InstallSymlink - ( symlinkBinaries ) + ( OverwritePolicy(..), symlinkBinaries ) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.Client.World as World import qualified Distribution.InstalledPackageInfo as Installed @@ -962,6 +962,7 @@ symlinkBinaries verbosity platform comp configFlags installFlags plan buildOutcomes = do failed <- InstallSymlink.symlinkBinaries platform comp + InstallSymlink.NeverOverwrite configFlags installFlags plan buildOutcomes case failed of diff --git a/Distribution/Client/InstallSymlink.hs b/Distribution/Client/InstallSymlink.hs --- a/Distribution/Client/InstallSymlink.hs +++ b/Distribution/Client/InstallSymlink.hs @@ -12,6 +12,7 @@ -- Managing installing binaries with symlinks. ----------------------------------------------------------------------------- module Distribution.Client.InstallSymlink ( + OverwritePolicy(..), symlinkBinaries, symlinkBinary, ) where @@ -27,16 +28,22 @@ import Distribution.Simple.Compiler import Distribution.System +data OverwritePolicy = NeverOverwrite | AlwaysOverwrite + deriving (Show, Eq) + symlinkBinaries :: Platform -> Compiler + -> OverwritePolicy -> ConfigFlags -> InstallFlags -> InstallPlan -> BuildOutcomes -> IO [(PackageIdentifier, UnqualComponentName, FilePath)] -symlinkBinaries _ _ _ _ _ _ = return [] +symlinkBinaries _ _ _ _ _ _ _ = return [] -symlinkBinary :: FilePath -> FilePath -> UnqualComponentName -> String -> IO Bool -symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows" +symlinkBinary :: OverwritePolicy + -> FilePath -> FilePath -> UnqualComponentName -> String + -> IO Bool +symlinkBinary _ _ _ _ _ = fail "Symlinking feature not available on Windows" #else @@ -87,6 +94,9 @@ import Data.Maybe ( catMaybes ) +data OverwritePolicy = NeverOverwrite | AlwaysOverwrite + deriving (Show, Eq) + -- | We would like by default to install binaries into some location that is on -- the user's PATH. For per-user installations on Unix systems that basically -- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@ @@ -108,12 +118,15 @@ -- with symlinks so is not available to Windows users. -- symlinkBinaries :: Platform -> Compiler + -> OverwritePolicy -> ConfigFlags -> InstallFlags -> InstallPlan -> BuildOutcomes -> IO [(PackageIdentifier, UnqualComponentName, FilePath)] -symlinkBinaries platform comp configFlags installFlags plan buildOutcomes = +symlinkBinaries platform comp overwritePolicy + configFlags installFlags + plan buildOutcomes = case flagToMaybe (installSymlinkBinDir installFlags) of Nothing -> return [] Just symlinkBinDir @@ -125,6 +138,7 @@ fmap catMaybes $ sequence [ do privateBinDir <- pkgBinDir pkg ipid ok <- symlinkBinary + overwritePolicy publicBinDir privateBinDir publicExeName privateExeName if ok @@ -187,7 +201,8 @@ (CompilerId compilerFlavor _) = compilerInfoId cinfo symlinkBinary :: - FilePath -- ^ The canonical path of the public bin dir eg + OverwritePolicy -- ^ Whether to force overwrite an existing file + -> FilePath -- ^ The canonical path of the public bin dir eg -- @/home/user/bin@ -> FilePath -- ^ The canonical path of the private bin dir eg -- @/home/user/.cabal/bin@ @@ -199,13 +214,16 @@ -- there was another file there already that we did -- not own. Other errors like permission errors just -- propagate as exceptions. -symlinkBinary publicBindir privateBindir publicName privateName = do +symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do ok <- targetOkToOverwrite (publicBindir publicName') (privateBindir privateName) case ok of - NotOurFile -> return False - NotExists -> mkLink >> return True - OkToOverwrite -> rmLink >> mkLink >> return True + NotExists -> mkLink >> return True + OkToOverwrite -> rmLink >> mkLink >> return True + NotOurFile -> + case overwritePolicy of + NeverOverwrite -> return False + AlwaysOverwrite -> rmLink >> mkLink >> return True where publicName' = display publicName relativeBindir = makeRelative publicBindir privateBindir diff --git a/Distribution/Client/ProjectBuilding.hs b/Distribution/Client/ProjectBuilding.hs --- a/Distribution/Client/ProjectBuilding.hs +++ b/Distribution/Client/ProjectBuilding.hs @@ -910,7 +910,7 @@ -> FilePath -> FilePath -> IO BuildResult buildAndInstallUnpackedPackage verbosity - DistDirLayout{distTempDirectory} + distDirLayout@DistDirLayout{distTempDirectory} storeDirLayout@StoreDirLayout { storePackageDBStack } @@ -963,12 +963,13 @@ annotateFailure mlogFile InstallFailed $ do let copyPkgFiles tmpDir = do - setup Cabal.copyCommand (copyFlags tmpDir) + let tmpDirNormalised = normalise tmpDir + setup Cabal.copyCommand (copyFlags tmpDirNormalised) -- Note that the copy command has put the files into -- @$tmpDir/$prefix@ so we need to return this dir so -- the store knows which dir will be the final store entry. - let prefix = dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) - entryDir = tmpDir prefix + let prefix = normalise $ dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) + entryDir = tmpDirNormalised prefix LBS.writeFile (entryDir "cabal-hash.txt") (renderPackageHashInputs (packageHashInputs pkgshared pkg)) @@ -977,7 +978,9 @@ -- While this breaks the prefix-relocatable property of the lirbaries -- it is necessary on macOS to stay under the load command limit of the -- macOS mach-o linker. See also @PackageHash.hashedInstalledPackageIdVeryShort@. - otherFiles <- filter (not . isPrefixOf entryDir) <$> listFilesRecursive tmpDir + -- We also normalise paths to ensure that there are no different representations + -- for the same path. Like / and \\ on windows under msys. + otherFiles <- filter (not . isPrefixOf entryDir) <$> listFilesRecursive tmpDirNormalised -- here's where we could keep track of the installed files ourselves -- if we wanted to by making a manifest of the files in the tmp dir return (entryDir, otherFiles) @@ -1086,7 +1089,8 @@ copyFlags destdir _ = setupHsCopyFlags pkg pkgshared verbosity builddir destdir - scriptOptions = setupHsScriptOptions rpkg plan pkgshared srcdir builddir + scriptOptions = setupHsScriptOptions rpkg plan pkgshared + distDirLayout srcdir builddir isParallelBuild cacheLock setup :: CommandUI flags -> (Version -> flags) -> IO () @@ -1099,7 +1103,7 @@ verbosity scriptOptions { useLoggingHandle = mLogFileHandle - , useExtraEnvOverrides = dataDirsEnvironmentForPlan plan } + , useExtraEnvOverrides = dataDirsEnvironmentForPlan distDirLayout plan } (Just (elabPkgDescription pkg)) cmd flags args @@ -1359,7 +1363,7 @@ setupHsHaddockArgs pkg scriptOptions = setupHsScriptOptions rpkg plan pkgshared - srcdir builddir + distDirLayout srcdir builddir isParallelBuild cacheLock setupInteractive :: CommandUI flags diff --git a/Distribution/Client/ProjectConfig/Legacy.hs b/Distribution/Client/ProjectConfig/Legacy.hs --- a/Distribution/Client/ProjectConfig/Legacy.hs +++ b/Distribution/Client/ProjectConfig/Legacy.hs @@ -325,7 +325,9 @@ configPreferences = projectConfigPreferences, configSolver = projectConfigSolver, configAllowOlder = projectConfigAllowOlder, - configAllowNewer = projectConfigAllowNewer + configAllowNewer = projectConfigAllowNewer, + configWriteGhcEnvironmentFilesPolicy + = projectConfigWriteGhcEnvironmentFilesPolicy } = configExFlags InstallFlags { @@ -536,8 +538,9 @@ configPreferences = projectConfigPreferences, configSolver = projectConfigSolver, configAllowOlder = projectConfigAllowOlder, - configAllowNewer = projectConfigAllowNewer - + configAllowNewer = projectConfigAllowNewer, + configWriteGhcEnvironmentFilesPolicy + = projectConfigWriteGhcEnvironmentFilesPolicy } installFlags = InstallFlags { @@ -893,7 +896,7 @@ (\v conf -> conf { configAllowNewer = fmap AllowNewer v }) ] . filterFields - [ "cabal-lib-version", "solver" + [ "cabal-lib-version", "solver", "write-ghc-environment-files" -- not "constraint" or "preference", we use our own plural ones above ] . commandOptionsToFields diff --git a/Distribution/Client/ProjectConfig/Types.hs b/Distribution/Client/ProjectConfig/Types.hs --- a/Distribution/Client/ProjectConfig/Types.hs +++ b/Distribution/Client/ProjectConfig/Types.hs @@ -21,7 +21,8 @@ ) where import Distribution.Client.Types - ( RemoteRepo, AllowNewer(..), AllowOlder(..) ) + ( RemoteRepo, AllowNewer(..), AllowOlder(..) + , WriteGhcEnvironmentFilesPolicy ) import Distribution.Client.Dependency.Types ( PreSolver ) import Distribution.Client.Targets @@ -186,6 +187,8 @@ projectConfigSolver :: Flag PreSolver, projectConfigAllowOlder :: Maybe AllowOlder, projectConfigAllowNewer :: Maybe AllowNewer, + projectConfigWriteGhcEnvironmentFilesPolicy + :: Flag WriteGhcEnvironmentFilesPolicy, projectConfigMaxBackjumps :: Flag Int, projectConfigReorderGoals :: Flag ReorderGoals, projectConfigCountConflicts :: Flag CountConflicts, diff --git a/Distribution/Client/ProjectOrchestration.hs b/Distribution/Client/ProjectOrchestration.hs --- a/Distribution/Client/ProjectOrchestration.hs +++ b/Distribution/Client/ProjectOrchestration.hs @@ -98,6 +98,8 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Compat.Directory + ( makeAbsolute ) import Distribution.Client.ProjectConfig import Distribution.Client.ProjectPlanning @@ -111,7 +113,8 @@ import Distribution.Client.Types ( GenericReadyPackage(..), UnresolvedSourcePackage , PackageSpecifier(..) - , SourcePackageDb(..) ) + , SourcePackageDb(..) + , WriteGhcEnvironmentFilesPolicy(..) ) import Distribution.Solver.Types.PackageIndex ( lookupPackageName ) import qualified Distribution.Client.InstallPlan as InstallPlan @@ -122,6 +125,8 @@ import Distribution.Client.DistDirLayout import Distribution.Client.Config (getCabalDir) import Distribution.Client.Setup hiding (packageName) +import Distribution.Compiler + ( CompilerFlavor(GHC) ) import Distribution.Types.ComponentName ( componentNameString ) import Distribution.Types.UnqualComponentName @@ -136,6 +141,8 @@ , diffFlagAssignment ) import Distribution.Simple.LocalBuildInfo ( ComponentName(..), pkgComponents ) +import Distribution.Simple.Flag + ( fromFlagOrDefault ) import qualified Distribution.Simple.Setup as Setup import Distribution.Simple.Command (commandShowOptions) import Distribution.Simple.Configure (computeEffectiveProfiling) @@ -143,9 +150,11 @@ import Distribution.Simple.Utils ( die', warn, notice, noticeNoWrap, debugNoWrap ) import Distribution.Verbosity +import Distribution.Version + ( mkVersion ) import Distribution.Text import Distribution.Simple.Compiler - ( showCompilerId + ( compilerCompatVersion, showCompilerId , OptimisationLevel(..)) import qualified Data.Monoid as Mon @@ -196,8 +205,8 @@ } = projectConfigShared projectConfig mlogsDir = Setup.flagToMaybe projectConfigLogsDir - mstoreDir = Setup.flagToMaybe projectConfigStoreDir - cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + mstoreDir <- sequenceA $ makeAbsolute <$> Setup.flagToMaybe projectConfigStoreDir + let cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir buildSettings = resolveBuildTimeSettings verbosity cabalDirLayout @@ -388,11 +397,27 @@ pkgsBuildStatus buildOutcomes - void $ writePlanGhcEnvironment (distProjectRootDirectory - distDirLayout) - elaboratedPlanOriginal - elaboratedShared - postBuildStatus + -- Write the .ghc.environment file (if allowed by the env file write policy). + let writeGhcEnvFilesPolicy = + projectConfigWriteGhcEnvironmentFilesPolicy . projectConfigShared + $ projectConfig + + shouldWriteGhcEnvironment = + case fromFlagOrDefault WriteGhcEnvironmentFilesOnlyForGhc844AndNewer + writeGhcEnvFilesPolicy + of + AlwaysWriteGhcEnvironmentFiles -> True + NeverWriteGhcEnvironmentFiles -> False + WriteGhcEnvironmentFilesOnlyForGhc844AndNewer -> + let compiler = pkgConfigCompiler elaboratedShared + ghcCompatVersion = compilerCompatVersion GHC compiler + in maybe False (>= mkVersion [8,4,4]) ghcCompatVersion + + when shouldWriteGhcEnvironment $ + void $ writePlanGhcEnvironment (distProjectRootDirectory distDirLayout) + elaboratedPlanOriginal + elaboratedShared + postBuildStatus -- Finally if there were any build failures then report them and throw -- an exception to terminate the program diff --git a/Distribution/Client/ProjectPlanOutput.hs b/Distribution/Client/ProjectPlanOutput.hs --- a/Distribution/Client/ProjectPlanOutput.hs +++ b/Distribution/Client/ProjectPlanOutput.hs @@ -19,7 +19,7 @@ import Distribution.Client.ProjectBuilding.Types import Distribution.Client.DistDirLayout import Distribution.Client.Types (Repo(..), RemoteRepo(..), PackageLocation(..), confInstId) -import Distribution.Client.PackageHash (showHashValue) +import Distribution.Client.PackageHash (showHashValue, hashValue) import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.Utils.Json as J @@ -141,6 +141,8 @@ , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab)) , "pkg-src" J..= packageLocationToJ (elabPkgSourceLocation elab) ] ++ + [ "pkg-cabal-sha256" J..= J.String (showHashValue hash) + | Just hash <- [ fmap hashValue (elabPkgDescriptionOverride elab) ] ] ++ [ "pkg-src-sha256" J..= J.String (showHashValue hash) | Just hash <- [elabPkgSourceHash elab] ] ++ (case elabBuildStyle elab of @@ -155,7 +157,8 @@ let components = J.object $ [ comp2str c J..= (J.object $ [ "depends" J..= map (jdisplay . confInstId) ldeps - , "exe-depends" J..= map (jdisplay . confInstId) edeps ] ++ + , "exe-depends" J..= map (jdisplay . confInstId) edeps + ] ++ bin_file c) | (c,(ldeps,edeps)) <- ComponentDeps.toList $ diff --git a/Distribution/Client/ProjectPlanning.hs b/Distribution/Client/ProjectPlanning.hs --- a/Distribution/Client/ProjectPlanning.hs +++ b/Distribution/Client/ProjectPlanning.hs @@ -1429,7 +1429,8 @@ compExeDependencyPaths = [ (annotatedIdToConfiguredId aid', path) | aid' <- cc_exe_deps cc0 - , Just path <- [Map.lookup (ann_id aid') exe_map1]] + , Just paths <- [Map.lookup (ann_id aid') exe_map1] + , path <- paths ] elab_comp = ElaboratedComponent {..} -- 3. Construct a preliminary ElaboratedConfiguredPackage, @@ -1514,10 +1515,10 @@ external_exe_dep_sids ++ external_lib_dep_sids external_exe_map = Map.fromList $ - [ (getComponentId pkg, path) + [ (getComponentId pkg, paths) | pkg <- external_exe_dep_pkgs - , Just path <- [planPackageExePath pkg] ] - exe_map1 = Map.union external_exe_map exe_map + , let paths = planPackageExePaths pkg ] + exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map external_lib_cc_map = Map.fromListWith Map.union $ map mkCCMapping external_lib_dep_pkgs @@ -1577,24 +1578,35 @@ -> SolverId -> [ElaboratedPlanPackage] elaborateLibSolverId mapDep = filter (matchPlanPkg (== CLibName)) . mapDep - -- | Given an 'ElaboratedPlanPackage', return the path to where the - -- executable that this package represents would be installed. - planPackageExePath :: ElaboratedPlanPackage -> Maybe FilePath - planPackageExePath = + -- | Given an 'ElaboratedPlanPackage', return the paths to where the + -- executables that this package represents would be installed. + -- The only case where multiple paths can be returned is the inplace + -- monolithic package one, since there can be multiple exes and each one + -- has its own directory. + planPackageExePaths :: ElaboratedPlanPackage -> [FilePath] + planPackageExePaths = -- Pre-existing executables are assumed to be in PATH -- already. In fact, this should be impossible. - InstallPlan.foldPlanPackage (const Nothing) $ \elab -> Just $ - binDirectoryFor - distDirLayout - elaboratedSharedConfig - elab $ - case elabPkgOrComp elab of - ElabPackage _ -> "" - ElabComponent comp -> - case fmap Cabal.componentNameString - (compComponentName comp) of - Just (Just n) -> display n - _ -> "" + InstallPlan.foldPlanPackage (const []) $ \elab -> + let + executables :: [FilePath] + executables = + case elabPkgOrComp elab of + -- Monolithic mode: all exes of the package + ElabPackage _ -> unUnqualComponentName . PD.exeName + <$> PD.executables (elabPkgDescription elab) + -- Per-component mode: just the selected exe + ElabComponent comp -> + case fmap Cabal.componentNameString + (compComponentName comp) of + Just (Just n) -> [display n] + _ -> [""] + in + binDirectoryFor + distDirLayout + elaboratedSharedConfig + elab + <$> executables elaborateSolverToPackage :: SolverPackage UnresolvedPkgLoc -> ComponentsGraph @@ -1763,6 +1775,7 @@ -- but this function doesn't know what is installed (since -- we haven't improved the plan yet), so we do it in another pass. -- Check the comments of those functions for more details. + elabConfigureTargets = [] elabBuildTargets = [] elabTestTargets = [] elabBenchTargets = [] @@ -1921,10 +1934,10 @@ where shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId shouldBeLocal NamedPackage{} = Nothing - shouldBeLocal (SpecificSourcePackage pkg) + shouldBeLocal (SpecificSourcePackage pkg) | LocalTarballPackage _ <- packageSource pkg = Nothing | otherwise = Just (packageId pkg) - -- TODO: Is it only LocalTarballPackages we can know about without + -- TODO: Is it only LocalTarballPackages we can know about without -- them being "local" in the sense meant here? -- -- Also, review use of SourcePackage's loc vs ProjectPackageLocation @@ -2403,7 +2416,7 @@ componentAvailableTargetStatus :: Component -> AvailableTargetStatus (UnitId, ComponentName) componentAvailableTargetStatus component = - case componentOptionalStanza (componentName component) of + case componentOptionalStanza $ CD.componentNameToComponent cname of -- it is not an optional stanza, so a library, exe or foreign lib Nothing | not buildable -> TargetNotBuildable @@ -2505,7 +2518,8 @@ -- | How 'pruneInstallPlanToTargets' should interpret the per-package -- 'ComponentTarget's: as build, repl or haddock targets. -- -data TargetAction = TargetActionBuild +data TargetAction = TargetActionConfigure + | TargetActionBuild | TargetActionRepl | TargetActionTest | TargetActionBench @@ -2578,6 +2592,7 @@ case (Map.lookup (installedUnitId elab) perPkgTargetsMap, targetAction) of (Nothing, _) -> elab + (Just tgts, TargetActionConfigure) -> elab { elabConfigureTargets = tgts } (Just tgts, TargetActionBuild) -> elab { elabBuildTargets = tgts } (Just tgts, TargetActionTest) -> elab { elabTestTargets = tgts } (Just tgts, TargetActionBench) -> elab { elabBenchTargets = tgts } @@ -2622,11 +2637,13 @@ $ addOptionalStanzas elab find_root (InstallPlan.Configured (PrunedPackage elab _)) = - if not (null (elabBuildTargets elab) - && null (elabTestTargets elab) - && null (elabBenchTargets elab) - && isNothing (elabReplTarget elab) - && null (elabHaddockTargets elab)) + if not $ and [ null (elabConfigureTargets elab) + , null (elabBuildTargets elab) + , null (elabTestTargets elab) + , null (elabBenchTargets elab) + , isNothing (elabReplTarget elab) + , null (elabHaddockTargets elab) + ] then Just (installedUnitId elab) else Nothing find_root _ = Nothing @@ -2719,7 +2736,9 @@ ++ elabBenchTargets pkg ++ maybeToList (elabReplTarget pkg) ++ elabHaddockTargets pkg - , stanza <- maybeToList (componentOptionalStanza cname) + , stanza <- maybeToList $ + componentOptionalStanza $ + CD.componentNameToComponent cname ] availablePkgs = @@ -2849,11 +2868,6 @@ mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = InstallPlan.PreExisting pkg -componentOptionalStanza :: Cabal.ComponentName -> Maybe OptionalStanza -componentOptionalStanza (Cabal.CTestName _) = Just TestStanzas -componentOptionalStanza (Cabal.CBenchName _) = Just BenchStanzas -componentOptionalStanza _ = Nothing - ------------------------------------ -- Support for --only-dependencies -- @@ -3102,6 +3116,7 @@ setupHsScriptOptions :: ElaboratedReadyPackage -> ElaboratedInstallPlan -> ElaboratedSharedConfig + -> DistDirLayout -> FilePath -> FilePath -> Bool @@ -3110,7 +3125,7 @@ -- TODO: Fix this so custom is a separate component. Custom can ALWAYS -- be a separate component!!! setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - plan ElaboratedSharedConfig{..} srcdir builddir + plan ElaboratedSharedConfig{..} distdir srcdir builddir isParallelBuild cacheLock = SetupScriptOptions { useCabalVersion = thisVersion elabSetupScriptCliVersion, @@ -3129,7 +3144,7 @@ useLoggingHandle = Nothing, -- this gets set later useWorkingDir = Just srcdir, useExtraPathEnv = elabExeDependencyPaths elab, - useExtraEnvOverrides = dataDirsEnvironmentForPlan plan, + useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan, useWin32CleanHack = False, --TODO: [required eventually] forceExternalSetupMethod = isParallelBuild, setupCacheLock = Just cacheLock, diff --git a/Distribution/Client/ProjectPlanning/Types.hs b/Distribution/Client/ProjectPlanning/Types.hs --- a/Distribution/Client/ProjectPlanning/Types.hs +++ b/Distribution/Client/ProjectPlanning/Types.hs @@ -54,6 +54,8 @@ isTestComponentTarget, isBenchComponentTarget, + componentOptionalStanza, + -- * Setup script SetupScriptStyle(..), ) where @@ -298,6 +300,7 @@ elabSetupScriptCliVersion :: Version, -- Build time related: + elabConfigureTargets :: [ComponentTarget], elabBuildTargets :: [ComponentTarget], elabTestTargets :: [ComponentTarget], elabBenchTargets :: [ComponentTarget], @@ -355,7 +358,24 @@ -- register in all cases, but some Custom Setups will fall -- over if you try to do that, ESPECIALLY if there actually is -- a library but they hadn't built it. - build_target || any (depends_on_lib pkg) (elabBuildTargets elab) + -- + -- However, as the case of `cpphs-1.20.8` has shown in + -- #5379, in cases when a monolithic package gets + -- installed due to its executable components + -- (i.e. exe:cpphs) into the store we *have* to register + -- if there's a buildable public library (i.e. lib:cpphs) + -- that was built and installed into the same store folder + -- as otherwise this will cause build failures once a + -- target actually depends on lib:cpphs. + build_target || (elabBuildStyle elab == BuildAndInstall && + Cabal.hasPublicLib (elabPkgDescription elab)) + -- the next sub-condition below is currently redundant + -- (see discussion in #5604 for more details), but it's + -- being kept intentionally here as a safeguard because if + -- internal libraries ever start working with + -- non-per-component builds this condition won't be + -- redundant anymore. + || any (depends_on_lib pkg) (elabBuildTargets elab) where depends_on_lib pkg (ComponentTarget cn _) = not (null (CD.select (== CD.componentNameToComponent cn) @@ -378,12 +398,13 @@ -- | Construct the environment needed for the data files to work. -- This consists of a separate @*_datadir@ variable for each -- inplace package in the plan. -dataDirsEnvironmentForPlan :: ElaboratedInstallPlan +dataDirsEnvironmentForPlan :: DistDirLayout + -> ElaboratedInstallPlan -> [(String, Maybe FilePath)] -dataDirsEnvironmentForPlan = catMaybes +dataDirsEnvironmentForPlan distDirLayout = catMaybes . fmap (InstallPlan.foldPlanPackage (const Nothing) - dataDirEnvVarForPackage) + (dataDirEnvVarForPackage distDirLayout)) . InstallPlan.toList -- | Construct an environment variable that points @@ -393,19 +414,27 @@ -- for inplace packages. -- * 'Nothing' for packages installed in the store (the path was -- already included in the package at install/build time). --- * The other cases are not handled yet. See below. -dataDirEnvVarForPackage :: ElaboratedConfiguredPackage +dataDirEnvVarForPackage :: DistDirLayout + -> ElaboratedConfiguredPackage -> Maybe (String, Maybe FilePath) -dataDirEnvVarForPackage pkg = - case (elabBuildStyle pkg, elabPkgSourceLocation pkg) - of (BuildAndInstall, _) -> Nothing - (BuildInplaceOnly, LocalUnpackedPackage path) -> Just - (pkgPathEnvVar (elabPkgDescription pkg) "datadir", - Just $ path dataDir (elabPkgDescription pkg)) - -- TODO: handle the other cases for PackageLocation. - -- We will only need this when we add support for - -- remote/local tarballs. - (BuildInplaceOnly, _) -> Nothing +dataDirEnvVarForPackage distDirLayout pkg = + case elabBuildStyle pkg + of BuildAndInstall -> Nothing + BuildInplaceOnly -> Just + ( pkgPathEnvVar (elabPkgDescription pkg) "datadir" + , Just $ srcPath (elabPkgSourceLocation pkg) + dataDir (elabPkgDescription pkg)) + where + srcPath (LocalUnpackedPackage path) = path + srcPath (LocalTarballPackage _path) = unpackedPath + srcPath (RemoteTarballPackage _uri _localTar) = unpackedPath + srcPath (RepoTarballPackage _repo _packageId _localTar) = unpackedPath + srcPath (RemoteSourceRepoPackage _sourceRepo (Just localCheckout)) = localCheckout + -- TODO: see https://github.com/haskell/cabal/wiki/Potential-Refactors#unresolvedpkgloc + srcPath (RemoteSourceRepoPackage _sourceRepo Nothing) = error + "calling dataDirEnvVarForPackage on a not-downloaded repo is an error" + unpackedPath = + distUnpackedSrcDirectory distDirLayout $ elabPkgSourceId pkg instance Package ElaboratedConfiguredPackage where packageId = elabPkgSourceId @@ -753,6 +782,11 @@ isSubLibComponentTarget (ComponentTarget (CSubLibName _) _) = True isSubLibComponentTarget _ = False +componentOptionalStanza :: CD.Component -> Maybe OptionalStanza +componentOptionalStanza (CD.ComponentTest _) = Just TestStanzas +componentOptionalStanza (CD.ComponentBench _) = Just BenchStanzas +componentOptionalStanza _ = Nothing + --------------------------- -- Setup.hs script policy -- @@ -781,4 +815,3 @@ deriving (Eq, Show, Generic, Typeable) instance Binary SetupScriptStyle - diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs --- a/Distribution/Client/Setup.hs +++ b/Distribution/Client/Setup.hs @@ -1,7 +1,8 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Setup @@ -57,6 +58,7 @@ , parsePackageArgs , liftOptions + , yesNoOpt --TODO: stop exporting these: , showRepo , parseRepo @@ -69,6 +71,7 @@ import Distribution.Client.Types ( Username(..), Password(..), RemoteRepo(..) , AllowNewer(..), AllowOlder(..), RelaxDeps(..) + , WriteGhcEnvironmentFilesPolicy(..) ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) @@ -610,12 +613,14 @@ -- | cabal configure takes some extra flags beyond runghc Setup configure -- data ConfigExFlags = ConfigExFlags { - configCabalVersion :: Flag Version, - configExConstraints:: [(UserConstraint, ConstraintSource)], - configPreferences :: [Dependency], - configSolver :: Flag PreSolver, - configAllowNewer :: Maybe AllowNewer, - configAllowOlder :: Maybe AllowOlder + configCabalVersion :: Flag Version, + configExConstraints :: [(UserConstraint, ConstraintSource)], + configPreferences :: [Dependency], + configSolver :: Flag PreSolver, + configAllowNewer :: Maybe AllowNewer, + configAllowOlder :: Maybe AllowOlder, + configWriteGhcEnvironmentFilesPolicy + :: Flag WriteGhcEnvironmentFilesPolicy } deriving (Eq, Generic) @@ -680,9 +685,34 @@ (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser) (Just RelaxDepsAll) relaxDepsPrinter) + , option [] ["write-ghc-environment-files"] + ("Whether to create a .ghc.environment file after a successful build" + ++ " (v2-build only)") + configWriteGhcEnvironmentFilesPolicy + (\v flags -> flags { configWriteGhcEnvironmentFilesPolicy = v}) + (reqArg "always|never|ghc8.4.4+" + writeGhcEnvironmentFilesPolicyParser + writeGhcEnvironmentFilesPolicyPrinter) ] +writeGhcEnvironmentFilesPolicyParser :: ReadE (Flag WriteGhcEnvironmentFilesPolicy) +writeGhcEnvironmentFilesPolicyParser = ReadE $ \case + "always" -> Right $ Flag AlwaysWriteGhcEnvironmentFiles + "never" -> Right $ Flag NeverWriteGhcEnvironmentFiles + "ghc8.4.4+" -> Right $ Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer + policy -> Left $ "Cannot parse the GHC environment file write policy '" + <> policy <> "'" + +writeGhcEnvironmentFilesPolicyPrinter + :: Flag WriteGhcEnvironmentFilesPolicy -> [String] +writeGhcEnvironmentFilesPolicyPrinter = \case + (Flag AlwaysWriteGhcEnvironmentFiles) -> ["always"] + (Flag NeverWriteGhcEnvironmentFiles) -> ["never"] + (Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer) -> ["ghc8.4.4+"] + NoFlag -> [] + + relaxDepsParser :: Parse.ReadP r (Maybe RelaxDeps) relaxDepsParser = (Just . RelaxDepsSome) `fmap` Parse.sepBy1 parse (Parse.char ',') @@ -2172,9 +2202,9 @@ (flagToList . fmap display)) , option [] ["cabal-version"] - "Required version of the Cabal library." + "Version of the Cabal specification." IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v }) - (reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal version range: "++) + (reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal specification version: "++) (toFlag `fmap` parse)) (flagToList . fmap display)) @@ -2282,6 +2312,14 @@ IT.buildTools (\v flags -> flags { IT.buildTools = v }) (reqArg' "TOOL" (Just . (:[])) (fromMaybe [])) + + -- NB: this is a bit of a transitional hack and will likely be + -- removed again if `cabal init` is migrated to the v2-* command + -- framework + , option "w" ["with-compiler"] + "give the path to a particular compiler" + IT.initHcPath (\v flags -> flags { IT.initHcPath = v }) + (reqArgFlag "PATH") , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v }) ] diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs --- a/Distribution/Client/Types.hs +++ b/Distribution/Client/Types.hs @@ -589,3 +589,19 @@ instance Monoid AllowOlder where mempty = AllowOlder mempty mappend = (<>) + +-- ------------------------------------------------------------ +-- * --write-ghc-environment-file +-- ------------------------------------------------------------ + +-- | Whether 'v2-build' should write a .ghc.environment file after +-- success. Possible values: 'always', 'never', 'ghc8.4.4+' (the +-- default; GHC 8.4.4 is the earliest version that supports +-- '-package-env -'). +data WriteGhcEnvironmentFilesPolicy + = AlwaysWriteGhcEnvironmentFiles + | NeverWriteGhcEnvironmentFiles + | WriteGhcEnvironmentFilesOnlyForGhc844AndNewer + deriving (Eq, Enum, Bounded, Generic, Show) + +instance Binary WriteGhcEnvironmentFilesPolicy diff --git a/bootstrap.sh b/bootstrap.sh --- a/bootstrap.sh +++ b/bootstrap.sh @@ -221,8 +221,8 @@ # >= 2.6.0.2 && < 2.7 NETWORK_VER="2.7.0.0"; NETWORK_VER_REGEXP="2\.[0-7]\." # >= 2.0 && < 2.7 -CABAL_VER="2.4.0.1"; CABAL_VER_REGEXP="2\.4\.[0-9]" - # >= 2.4 && < 2.5 +CABAL_VER="2.4.1.0"; CABAL_VER_REGEXP="2\.4\.[1-9]" + # >= 2.4.1.0 && < 2.5 TRANS_VER="0.5.5.0"; TRANS_VER_REGEXP="0\.[45]\." # >= 0.2.* && < 0.6 MTL_VER="2.2.2"; MTL_VER_REGEXP="[2]\." diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -4,7 +4,7 @@ -- To update this file, edit 'cabal-install.cabal.pp' and run -- 'make cabal-install-prod' in the project's root folder. Name: cabal-install -Version: 2.4.0.0 +Version: 2.4.1.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing @@ -297,31 +297,31 @@ Paths_cabal_install build-depends: - async >= 2.0 && < 3, + async >= 2.0 && < 2.3, array >= 0.4 && < 0.6, - base >= 4.6 && < 5, + base >= 4.8 && < 4.13, base16-bytestring >= 0.1.1 && < 0.2, - binary >= 0.7 && < 0.9, - bytestring >= 0.10.2 && < 1, - Cabal == 2.4.*, - containers >= 0.5 && < 0.7, + binary >= 0.7.3 && < 0.9, + bytestring >= 0.10.6.0 && < 0.11, + Cabal >= 2.4.1.0 && < 2.5, + containers >= 0.5.6.2 && < 0.7, cryptohash-sha256 >= 0.11 && < 0.12, - deepseq >= 1.3 && < 1.5, + deepseq >= 1.4.1.1 && < 1.5, directory >= 1.2.2.0 && < 1.4, echo >= 0.1.3 && < 0.2, edit-distance >= 0.2.2 && < 0.3, - filepath >= 1.3 && < 1.5, - hashable >= 1.0 && < 2, + filepath >= 1.4.0.0 && < 1.5, + hashable >= 1.0 && < 1.3, HTTP >= 4000.1.5 && < 4000.4, - mtl >= 2.0 && < 3, + mtl >= 2.0 && < 2.3, network-uri >= 2.6.0.2 && < 2.7, - network >= 2.6 && < 2.8, + network >= 2.6 && < 2.9, pretty >= 1.1 && < 1.2, - process >= 1.1.0.2 && < 1.7, + process >= 1.2.3.0 && < 1.7, random >= 1 && < 1.2, - stm >= 2.0 && < 3, + stm >= 2.0 && < 2.6, tar >= 0.5.0.3 && < 0.6, - time >= 1.4 && < 1.10, + time >= 1.5.0.1 && < 1.10, zlib >= 0.5.3 && < 0.7, hackage-security >= 0.5.2.2 && < 0.6, text >= 1.2.3 && < 1.3, @@ -337,7 +337,7 @@ if os(windows) build-depends: Win32 >= 2 && < 3 else - build-depends: unix >= 2.5 && < 2.9 + build-depends: unix >= 2.5 && < 2.8 if flag(debug-expensive-assertions) cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,7 +1,35 @@ -*-change-log-*- +2.4.1.0 Mikhail Glushenkov November 2018 + * Add message to alert user to potential package casing errors. (#5635) + * new-clean no longer deletes dist-newstyle/src with `-s`. (#5699) + * 'new-install' now warns when failing to symlink an exe (#5602) + * Extend 'cabal init' support for 'cabal-version' selection (#5567) + * 'new-sdist' now generates tarballs with file modification + times from a date in 2001. Using the Unix epoch caused + problems on Windows. (#5596) + * Register monolithic packages installed into the store due to a + build-tool dependency if they also happen to contain a buildable + public lib. (#5379,#5604) + * Fixed a Windows bug where cabal-install tried to copy files + after moving them (#5631). + * 'cabal v2-repl' now works for indefinite (in the Backpack sense) components. (#5619) + * Set data dir environment variable for tarballs and remote repos (#5469) + * Fix monolithic inplace build tool PATH (#5633) + * 'cabal init' now supports '-w'/'--with-compiler' flag (#4936, #5654) + * Fix ambiguous --builddir on new-install (#5652) + * Allow relative --storedir (#5662) + * Respect --dry on new-install (#5671) + * Warn when new-installing zero exes (#5666) + * Add 'pkg-cabal-sha256' field to plan.json (#5695) + * New v2-build flag: '--only-configure'. (#5578) + * Fixed a 'new-install' failure that manifested when it + encountered remote source dependencies in a project. (#5643) + * New 'v2-[build,configure' flag: '--write-ghc-environment-files' + to control the generation of .ghc.environment files. (#5711) + 2.4.0.0 Mikhail Glushenkov September 2018 - * Bugfix: "cabal new-build --ghc-option '--bogus' --ghc-option '-O1'" + * Bugfix: "cabal new-build --ghc-option '--bogus' --ghc-option '-O1'" no longer ignores all arguments except the last one (#5512). * Add the following option aliases for '-dir'-suffixed options: 'storedir', 'logsdir', 'packagedir', 'sourcedir', 'outputdir' (#5484). @@ -50,6 +78,9 @@ * Default changelog generated by 'cabal init' is now named 'CHANGELOG.md' (#5441). * Align output of 'new-build' command phases (#4040). + * Add suport for specifying remote VCS dependencies via new + 'source-repository-package' stanzas in 'cabal.project' files + (#5351). 2.2.0.0 Mikhail Glushenkov March 2018 * '--with-PROG' and '--PROG-options' are applied to all packages @@ -117,8 +148,8 @@ * Paths_ autogen modules now compile when `RebindableSyntax` or `OverloadedStrings` is used in `default-extensions`. [stack#3789](https://github.com/commercialhaskell/stack/issues/3789) - * getDataDir` and other `Paths_autogen` functions now work correctly - when compiling a custom `Setup.hs` script using `new-build` (#5164). + * `getDataDir` and other `Paths_autogen` functions now work correctly + when compiling a custom `Setup.hs` script using `new-build` (#5164). 2.0.0.1 Mikhail Glushenkov December 2017 * Support for GHC's numeric -g debug levels (#4673). diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -38,7 +38,7 @@ , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand , runCommand - , InitFlags(initVerbosity), initCommand + , InitFlags(initVerbosity, initHcPath), initCommand , SDistFlags(..), SDistExFlags(..), sdistCommand , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand , ActAsSetupFlags(..), actAsSetupCommand @@ -1143,7 +1143,9 @@ die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity (globalFlags { globalRequireSandbox = Flag False }) - let configFlags = savedConfigureFlags config + let configFlags = savedConfigureFlags config `mappend` + -- override with `--with-compiler` from CLI if available + mempty { configHcPath = initHcPath initFlags } let globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, _, progdb) <- configCompilerAux' configFlags withRepoContext verbosity globalFlags' $ \repoContext ->