Commit ac7716f2 authored by Oleg Grenrus's avatar Oleg Grenrus

Add --ignore-project to v2-sdist

Also refactor it to use more of utilities, i.e. be consistent
parent c49bb4eb
......@@ -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.
......
......@@ -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 )
......
......@@ -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 )
......
......@@ -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
......
......@@ -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
......
......@@ -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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment