Cabal v2-sdist --ignore-project

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.

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 )

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 )

cabal-install/Distribution/Client/CmdSdist.hs

@@ -15,22 +15,20 @@ 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
     ( 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,17 +177,46 @@ 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
         Right pkgs
             | 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

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