diff --git a/cabal-install/Distribution/Client/CmdInstall.hs b/cabal-install/Distribution/Client/CmdInstall.hs index b741cd0c6ad..c872f26a588 100644 --- a/cabal-install/Distribution/Client/CmdInstall.hs +++ b/cabal-install/Distribution/Client/CmdInstall.hs @@ -55,7 +55,7 @@ import Distribution.Client.ProjectConfig.Types , ProjectConfigBuildOnly(..), PackageConfig(..) , getMapLast, getMapMappend, projectConfigLogsDir , projectConfigStoreDir, projectConfigBuildOnly - , projectConfigDistDir, projectConfigConfigFile ) + , projectConfigConfigFile ) import Distribution.Simple.Program.Db ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb , modifyProgramSearchPath, ProgramDb ) @@ -79,14 +79,13 @@ import Distribution.Solver.Types.PackageConstraint import Distribution.Client.IndexUtils ( getSourcePackages, getInstalledPackages ) import Distribution.Client.ProjectConfig - ( readGlobalConfig, projectConfigWithBuilderRepoContext + ( projectConfigWithBuilderRepoContext , resolveBuildTimeSettings, withProjectOrGlobalConfigIgn ) import Distribution.Client.ProjectPlanning ( storePackageInstallDirs' ) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Client.DistDirLayout - ( defaultDistDirLayout, DistDirLayout(..), mkCabalDirLayout - , ProjectRoot(ProjectRootImplicit) + ( DistDirLayout(..), mkCabalDirLayout , cabalStoreDirLayout , CabalDirLayout(..), StoreDirLayout(..) ) import Distribution.Client.RebuildMonad @@ -878,66 +877,6 @@ entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) [] | any hasLib targets = [GhcEnvFilePackageId unitId] | otherwise = [] --- | Create a dummy project context, without a .cabal or a .cabal.project file --- (a place where to put a temporary dist directory is still needed) -establishDummyProjectBaseContext - :: Verbosity - -> ProjectConfig - -> DistDirLayout - -- ^ Where to put the dist directory - -> [PackageSpecifier UnresolvedSourcePackage] - -- ^ The packages to be included in the project - -> CurrentCommand - -> IO ProjectBaseContext -establishDummyProjectBaseContext verbosity cliConfig distDirLayout localPackages currentCommand = do - cabalDir <- getCabalDir - - globalConfig <- runRebuild "" - $ readGlobalConfig verbosity - $ projectConfigConfigFile - $ projectConfigShared cliConfig - let projectConfig = globalConfig <> cliConfig - - let ProjectConfigBuildOnly { - projectConfigLogsDir - } = projectConfigBuildOnly projectConfig - - ProjectConfigShared { - projectConfigStoreDir - } = projectConfigShared projectConfig - - mlogsDir = flagToMaybe projectConfigLogsDir - mstoreDir = flagToMaybe projectConfigStoreDir - cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir - - buildSettings = resolveBuildTimeSettings - verbosity cabalDirLayout - projectConfig - - return ProjectBaseContext { - distDirLayout, - cabalDirLayout, - projectConfig, - localPackages, - buildSettings, - currentCommand - } - -establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout -establishDummyDistDirLayout verbosity cliConfig tmpDir = do - let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory - - -- Create the dist directories - createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout - createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout - - return distDirLayout - where - mdistDirectory = flagToMaybe - $ projectConfigDistDir - $ projectConfigShared cliConfig - projectRoot = ProjectRootImplicit tmpDir - -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, -- or otherwise classifies the problem. diff --git a/cabal-install/Distribution/Client/CmdRepl.hs b/cabal-install/Distribution/Client/CmdRepl.hs index b5fd07aff7f..3c93ad98879 100644 --- a/cabal-install/Distribution/Client/CmdRepl.hs +++ b/cabal-install/Distribution/Client/CmdRepl.hs @@ -24,10 +24,6 @@ import Distribution.Compat.Lens import qualified Distribution.Types.Lens as L import Distribution.Client.CmdErrorMessages -import Distribution.Client.CmdInstall - ( establishDummyDistDirLayout - , establishDummyProjectBaseContext - ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.ProjectBuilding ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages ) diff --git a/cabal-install/Distribution/Client/CmdRun.hs b/cabal-install/Distribution/Client/CmdRun.hs index 33eec4176dd..dfa9675066a 100644 --- a/cabal-install/Distribution/Client/CmdRun.hs +++ b/cabal-install/Distribution/Client/CmdRun.hs @@ -46,9 +46,6 @@ import Distribution.Verbosity import Distribution.Simple.Utils ( wrapText, warn, die', ordNub, info , createTempDirectory, handleDoesNotExist ) -import Distribution.Client.CmdInstall - ( establishDummyDistDirLayout - , establishDummyProjectBaseContext ) import Distribution.Client.ProjectConfig ( ProjectConfig(..), ProjectConfigShared(..) , withProjectOrGlobalConfigIgn ) diff --git a/cabal-install/Distribution/Client/CmdSdist.hs b/cabal-install/Distribution/Client/CmdSdist.hs index a22317004c4..55d01ad24a5 100644 --- a/cabal-install/Distribution/Client/CmdSdist.hs +++ b/cabal-install/Distribution/Client/CmdSdist.hs @@ -15,12 +15,10 @@ import Distribution.Client.Compat.Prelude import Distribution.Client.CmdErrorMessages ( Plural(..), renderComponentKind ) import Distribution.Client.ProjectOrchestration - ( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext ) + ( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext, establishProjectBaseContextWithRoot) import Distribution.Client.TargetSelector ( TargetSelector(..), ComponentKind , readTargetSelectors, reportTargetSelectorProblems ) -import Distribution.Client.RebuildMonad - ( runRebuild ) import Distribution.Client.Setup ( GlobalFlags(..) ) import Distribution.Solver.Types.SourcePackage @@ -28,9 +26,9 @@ import Distribution.Solver.Types.SourcePackage import Distribution.Client.Types ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage ) import Distribution.Client.DistDirLayout - ( DistDirLayout(..), defaultDistDirLayout ) + ( DistDirLayout(..), ProjectRoot (..) ) import Distribution.Client.ProjectConfig - ( findProjectRoot, readProjectConfig ) + ( ProjectConfig, withProjectOrGlobalConfigIgn, commandLineFlagsToProjectConfig, projectConfigConfigFile, projectConfigShared ) import Distribution.Package ( Package(packageId) ) @@ -46,7 +44,7 @@ import Distribution.Simple.PreProcess ( knownSuffixHandlers ) import Distribution.Simple.Setup ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe - , optionVerbosity, optionDistPref, trueArg + , optionVerbosity, optionDistPref, trueArg, configVerbosity, configDistPref ) import Distribution.Simple.SrcDist ( listPackageSources ) @@ -62,8 +60,6 @@ import Distribution.Verbosity import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Compression.GZip as GZip -import Control.Exception - ( throwIO ) import Control.Monad.Trans ( liftIO ) import Control.Monad.State.Lazy @@ -103,15 +99,19 @@ sdistCommand = CommandUI "Set the name of the cabal.project file to search for in parent directories" sdistProjectFile (\pf flags -> flags { sdistProjectFile = pf }) (reqArg "FILE" (succeedReadE Flag) flagToList) + , option ['z'] ["ignore-project"] + "Ignore local project configuration" + sdistIgnoreProject (\v flags -> flags { sdistIgnoreProject = v }) + trueArg , option ['l'] ["list-only"] "Just list the sources, do not make a tarball" sdistListSources (\v flags -> flags { sdistListSources = v }) trueArg - , option ['z'] ["null-sep"] + , option [] ["null-sep"] "Separate the source files with NUL bytes rather than newlines." sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v }) trueArg - , option ['o'] ["output-dir", "outputdir"] + , option ['o'] ["output-directory", "outputdir"] "Choose the output directory of this command. '-' sends all output to stdout" sdistOutputPath (\o flags -> flags { sdistOutputPath = o }) (reqArg "PATH" (succeedReadE Flag) flagToList) @@ -122,6 +122,7 @@ data SdistFlags = SdistFlags { sdistVerbosity :: Flag Verbosity , sdistDistDir :: Flag FilePath , sdistProjectFile :: Flag FilePath + , sdistIgnoreProject :: Flag Bool , sdistListSources :: Flag Bool , sdistNulSeparated :: Flag Bool , sdistOutputPath :: Flag FilePath @@ -132,6 +133,7 @@ defaultSdistFlags = SdistFlags { sdistVerbosity = toFlag normal , sdistDistDir = mempty , sdistProjectFile = mempty + , sdistIgnoreProject = toFlag False , sdistListSources = toFlag False , sdistNulSeparated = toFlag False , sdistOutputPath = mempty @@ -141,30 +143,25 @@ defaultSdistFlags = SdistFlags sdistAction :: SdistFlags -> [String] -> GlobalFlags -> IO () sdistAction SdistFlags{..} targetStrings globalFlags = do - let verbosity = fromFlagOrDefault normal sdistVerbosity - mDistDirectory = flagToMaybe sdistDistDir - mProjectFile = flagToMaybe sdistProjectFile - globalConfig = globalConfigFile globalFlags - listSources = fromFlagOrDefault False sdistListSources - nulSeparated = fromFlagOrDefault False sdistNulSeparated - mOutputPath = flagToMaybe sdistOutputPath - - projectRoot <- either throwIO return =<< findProjectRoot Nothing mProjectFile - let distLayout = defaultDistDirLayout projectRoot mDistDirectory - dir <- getCurrentDirectory - projectConfig <- runRebuild dir $ readProjectConfig verbosity globalConfig distLayout - baseCtx <- establishProjectBaseContext verbosity projectConfig OtherCommand + (baseCtx, distDirLayout) <- withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag withProject withoutProject + let localPkgs = localPackages baseCtx targetSelectors <- either (reportTargetSelectorProblems verbosity) return =<< readTargetSelectors localPkgs Nothing targetStrings + -- elaborate path, create target directory mOutputPath' <- case mOutputPath of Just "-" -> return (Just "-") - Just path -> Just <$> makeAbsolute path - Nothing -> return Nothing - - let + Just path -> do + abspath <- makeAbsolute path + createDirectoryIfMissing True abspath + return (Just abspath) + Nothing -> do + createDirectoryIfMissing True (distSdistDirectory distDirLayout) + return Nothing + + let format :: OutputFormat format = if | listSources, nulSeparated -> SourceList '\0' | listSources -> SourceList '\n' @@ -180,9 +177,8 @@ sdistAction SdistFlags{..} targetStrings globalFlags = do | otherwise -> path prettyShow (packageId pkg) <.> ext Nothing | listSources -> "-" - | otherwise -> distSdistFile distLayout (packageId pkg) + | otherwise -> distSdistFile distDirLayout (packageId pkg) - createDirectoryIfMissing True (distSdistDirectory distLayout) case reifyTargetSelectors localPkgs targetSelectors of Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs @@ -190,7 +186,37 @@ sdistAction SdistFlags{..} targetStrings globalFlags = do | length pkgs > 1, not listSources, Just "-" <- mOutputPath' -> die' verbosity "Can't write multiple tarballs to standard output!" | otherwise -> - traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distLayout) format (outputPath pkg) pkg) pkgs + traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs + where + verbosity = fromFlagOrDefault normal sdistVerbosity + listSources = fromFlagOrDefault False sdistListSources + nulSeparated = fromFlagOrDefault False sdistNulSeparated + mOutputPath = flagToMaybe sdistOutputPath + ignoreProject = fromFlagOrDefault False sdistIgnoreProject + + prjConfig :: ProjectConfig + prjConfig = commandLineFlagsToProjectConfig + globalFlags + mempty { configVerbosity = sdistVerbosity, configDistPref = sdistDistDir } + mempty + mempty + mempty + mempty + mempty + mempty + + globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig) + + withProject :: IO (ProjectBaseContext, DistDirLayout) + withProject = do + baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand + return (baseCtx, distDirLayout baseCtx) + + withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout) + withoutProject config = do + cwd <- getCurrentDirectory + baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand + return (baseCtx, distDirLayout baseCtx) data IsExec = Exec | NoExec deriving (Show, Eq) @@ -237,10 +263,7 @@ packageToSdist verbosity projectRootDir format outputFile pkg = do (norm NoExec -> nonexec, norm Exec -> exec) <- listPackageSources verbosity (flattenPackageDescription $ packageDescription pkg) knownSuffixHandlers - print $ map snd exec - print $ map snd nonexec let files = nub . sortOn snd $ nonexec ++ exec - print files case format of SourceList nulSep -> do diff --git a/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal-install/Distribution/Client/ProjectConfig.hs index 45d1a0aa6d2..d3ca6913202 100644 --- a/cabal-install/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/Distribution/Client/ProjectConfig.hs @@ -470,7 +470,7 @@ renderBadProjectRoot (BadProjectRootExplicitFile projectFile) = withProjectOrGlobalConfigIgn :: Bool -- ^ whether to ignore local project -> Verbosity - -> Flag FilePath + -> Flag FilePath -- ^ global config file -> IO a -> (ProjectConfig -> IO a) -> IO a diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index 3613b057ba2..ff4deba5473 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -43,6 +43,7 @@ module Distribution.Client.ProjectOrchestration ( -- * Discovery phase: what is in the project? CurrentCommand(..), establishProjectBaseContext, + establishProjectBaseContextWithRoot, ProjectBaseContext(..), BuildTimeSettings(..), commandLineFlagsToProjectConfig, @@ -95,6 +96,10 @@ module Distribution.Client.ProjectOrchestration ( -- * Shared CLI utils cmdCommonHelpTextNewBuildBeta, + + -- * Dummy projects + establishDummyProjectBaseContext, + establishDummyDistDirLayout, ) where import Prelude () @@ -110,6 +115,7 @@ import qualified Distribution.Client.ProjectPlanning as ProjectPlanning import Distribution.Client.ProjectPlanning.Types import Distribution.Client.ProjectBuilding import Distribution.Client.ProjectPlanOutput +import Distribution.Client.RebuildMonad ( runRebuild ) import Distribution.Client.Types ( GenericReadyPackage(..), UnresolvedSourcePackage @@ -142,13 +148,13 @@ import Distribution.PackageDescription import Distribution.Simple.LocalBuildInfo ( ComponentName(..), pkgComponents ) import Distribution.Simple.Flag - ( fromFlagOrDefault ) + ( fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.Setup as Setup import Distribution.Simple.Command (commandShowOptions) import Distribution.Simple.Configure (computeEffectiveProfiling) import Distribution.Simple.Utils - ( die', warn, notice, noticeNoWrap, debugNoWrap ) + ( die', warn, notice, noticeNoWrap, debugNoWrap, createDirectoryIfMissingVerbose ) import Distribution.Verbosity import Distribution.Version ( mkVersion ) @@ -187,18 +193,29 @@ data ProjectBaseContext = ProjectBaseContext { currentCommand :: CurrentCommand } -establishProjectBaseContext :: Verbosity - -> ProjectConfig - -> CurrentCommand - -> IO ProjectBaseContext +establishProjectBaseContext + :: Verbosity + -> ProjectConfig + -> CurrentCommand + -> IO ProjectBaseContext establishProjectBaseContext verbosity cliConfig currentCommand = do + projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile + establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand + where + mprojectFile = Setup.flagToMaybe projectConfigProjectFile + ProjectConfigShared { projectConfigProjectFile } = projectConfigShared cliConfig +-- | Like 'establishProjectBaseContext' but doesn't search for project root. +establishProjectBaseContextWithRoot + :: Verbosity + -> ProjectConfig + -> ProjectRoot + -> CurrentCommand + -> IO ProjectBaseContext +establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand = do cabalDir <- getCabalDir - projectRoot <- either throwIO return =<< - findProjectRoot Nothing mprojectFile - let distDirLayout = defaultDistDirLayout projectRoot - mdistDirectory + let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory (projectConfig, localPackages) <- rebuildProjectConfig verbosity @@ -236,11 +253,7 @@ establishProjectBaseContext verbosity cliConfig currentCommand = do } where mdistDirectory = Setup.flagToMaybe projectConfigDistDir - mprojectFile = Setup.flagToMaybe projectConfigProjectFile - ProjectConfigShared { - projectConfigDistDir, - projectConfigProjectFile - } = projectConfigShared cliConfig + ProjectConfigShared { projectConfigDistDir } = projectConfigShared cliConfig -- | This holds the context between the pre-build, build and post-build phases. @@ -1227,3 +1240,67 @@ cmdCommonHelpTextNewBuildBeta = ++ "https://github.com/haskell/cabal/issues and if you\nhave any time " ++ "to get involved and help with testing, fixing bugs etc then\nthat " ++ "is very much appreciated.\n" + +------------------------------------------------------------------------------- +-- Dummy projects +------------------------------------------------------------------------------- + +-- | Create a dummy project context, without a .cabal or a .cabal.project file +-- (a place where to put a temporary dist directory is still needed) +establishDummyProjectBaseContext + :: Verbosity + -> ProjectConfig + -> DistDirLayout + -- ^ Where to put the dist directory + -> [PackageSpecifier UnresolvedSourcePackage] + -- ^ The packages to be included in the project + -> CurrentCommand + -> IO ProjectBaseContext +establishDummyProjectBaseContext verbosity cliConfig distDirLayout localPackages currentCommand = do + cabalDir <- getCabalDir + + globalConfig <- runRebuild "" + $ readGlobalConfig verbosity + $ projectConfigConfigFile + $ projectConfigShared cliConfig + let projectConfig = globalConfig <> cliConfig + + let ProjectConfigBuildOnly { + projectConfigLogsDir + } = projectConfigBuildOnly projectConfig + + ProjectConfigShared { + projectConfigStoreDir + } = projectConfigShared projectConfig + + mlogsDir = flagToMaybe projectConfigLogsDir + mstoreDir = flagToMaybe projectConfigStoreDir + cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + + buildSettings = resolveBuildTimeSettings + verbosity cabalDirLayout + projectConfig + + return ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages, + buildSettings, + currentCommand + } + +establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout +establishDummyDistDirLayout verbosity cliConfig tmpDir = do + let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory + + -- Create the dist directories + createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout + createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout + + return distDirLayout + where + mdistDirectory = flagToMaybe + $ projectConfigDistDir + $ projectConfigShared cliConfig + projectRoot = ProjectRootImplicit tmpDir diff --git a/cabal-testsuite/PackageTests/Regression/T5318/sdist-list-sources.out b/cabal-testsuite/PackageTests/Regression/T5318/sdist-list-sources.out index 0db80a07961..82b4544383a 100644 --- a/cabal-testsuite/PackageTests/Regression/T5318/sdist-list-sources.out +++ b/cabal-testsuite/PackageTests/Regression/T5318/sdist-list-sources.out @@ -1,3 +1,2 @@ -# cabal v1-sdist -List of package sources written to file '/sources' -List of package sources written to file '/sources' +# cabal v2-sdist +Wrote source list to /empty-data-dir-0.list diff --git a/cabal-testsuite/PackageTests/Regression/T5318/sdist-list-sources.test.hs b/cabal-testsuite/PackageTests/Regression/T5318/sdist-list-sources.test.hs index 895d74d0f53..3c68fbc9d75 100644 --- a/cabal-testsuite/PackageTests/Regression/T5318/sdist-list-sources.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T5318/sdist-list-sources.test.hs @@ -1,7 +1,7 @@ import Test.Cabal.Prelude main = cabalTest $ do tmpdir <- fmap testTmpDir getTestEnv - let fn = tmpdir "sources" - cabal "v1-sdist" ["--list-sources=" ++ fn] + let fn = tmpdir "empty-data-dir-0.list" + cabal "v2-sdist" ["--ignore-project", "--list-only", "--output-directory", tmpdir] -- --list-sources outputs with slashes on posix and backslashes on Windows. 'normalise' converts our needle to the necessary format. assertFileDoesContain fn $ normalise "foo.dat" diff --git a/cabal-testsuite/PackageTests/SDist/T5195/cabal.out b/cabal-testsuite/PackageTests/SDist/T5195/cabal.out index 9e5b0288b82..dda7897c3c8 100644 --- a/cabal-testsuite/PackageTests/SDist/T5195/cabal.out +++ b/cabal-testsuite/PackageTests/SDist/T5195/cabal.out @@ -1,2 +1,2 @@ -# cabal v1-sdist +# cabal v2-sdist cabal: filepath wildcard './actually-a-directory' does not match any files. diff --git a/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs b/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs index f2c49f56fa7..cb252f135e9 100644 --- a/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs +++ b/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs @@ -1,6 +1,5 @@ import Test.Cabal.Prelude main = cabalTest $ do tmpdir <- fmap testTmpDir getTestEnv - let fn = tmpdir "sources" - res <- fails $ cabal' "v1-sdist" ["--list-sources=" ++ fn] + res <- fails $ cabal' "v2-sdist" ["--ignore-project", "--list-only", "--output-directory", tmpdir] assertOutputContains "filepath wildcard './actually-a-directory' does not match any files" res