Skip to content

Implement the preliminary sandbox UI #1011

Merged
merged 8 commits into from Aug 24, 2012
View
8 Cabal/Distribution/Simple/GHC.hs
@@ -65,6 +65,7 @@ module Distribution.Simple.GHC (
buildLib, buildExe,
installLib, installExe,
libAbiHash,
+ initPackageDB,
registerPackage,
componentGhcOptions,
ghcLibDir,
@@ -1105,10 +1106,15 @@ updateLibArchive verbosity lbi path
rawSystemProgram verbosity ranlib [path]
| otherwise = return ()
-
-- -----------------------------------------------------------------------------
-- Registering
+-- | Create an empty package DB at the specified location.
+initPackageDB :: Verbosity -> ProgramConfiguration -> FilePath -> IO ()
+initPackageDB verbosity conf dbPath = HcPkg.init verbosity ghcPkgProg dbPath
+ where
+ Just ghcPkgProg = lookupProgram ghcPkgProgram conf
+
registerPackage
:: Verbosity
-> InstalledPackageInfo
View
20 Cabal/Distribution/Simple/Program/HcPkg.hs
@@ -10,6 +10,7 @@
-- Currently only GHC and LHC have hc-pkg programs.
module Distribution.Simple.Program.HcPkg (
+ init,
register,
reregister,
unregister,
@@ -18,6 +19,7 @@ module Distribution.Simple.Program.HcPkg (
dump,
-- * Program invocations
+ initInvocation,
registerInvocation,
reregisterInvocation,
unregisterInvocation,
@@ -26,6 +28,7 @@ module Distribution.Simple.Program.HcPkg (
dumpInvocation,
) where
+import Prelude hiding (init)
import Distribution.Package
( PackageId, InstalledPackageId(..) )
import Distribution.InstalledPackageInfo
@@ -62,6 +65,15 @@ import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
+-- | Call @hc-pkg@ to initialise a package database at the location {path}.
+--
+-- > hc-pkg init {path}
+--
+init :: Verbosity -> ConfiguredProgram -> FilePath -> IO ()
+init verbosity hcPkg path =
+ runProgramInvocation verbosity
+ (initInvocation hcPkg verbosity path)
+
-- | Call @hc-pkg@ to register a package.
--
-- > hc-pkg register {filename | -} [--user | --global | --package-db]
@@ -228,6 +240,14 @@ setInstalledPackageId pkginfo = pkginfo
-- The program invocations
--
+initInvocation :: ConfiguredProgram
+ -> Verbosity -> FilePath -> ProgramInvocation
+initInvocation hcPkg verbosity path =
+ programInvocation hcPkg args
+ where
+ args = ["init", path]
+ ++ verbosityOpts hcPkg verbosity
+
registerInvocation, reregisterInvocation
:: ConfiguredProgram -> Verbosity -> PackageDBStack
-> Either FilePath InstalledPackageInfo
View
16 Cabal/Distribution/Simple/Register.hs
@@ -57,6 +57,7 @@ module Distribution.Simple.Register (
register,
unregister,
+ initPackageDB,
registerPackage,
generateRegistrationInfo,
inplaceInstalledPackageInfo,
@@ -73,11 +74,12 @@ import qualified Distribution.Simple.LHC as LHC
import qualified Distribution.Simple.Hugs as Hugs
import qualified Distribution.Simple.UHC as UHC
import Distribution.Simple.Compiler
- ( compilerVersion, CompilerFlavor(..), compilerFlavor
+ ( compilerVersion, Compiler, CompilerFlavor(..), compilerFlavor
, PackageDBStack, registrationPackageDB )
import Distribution.Simple.Program
- ( ConfiguredProgram, runProgramInvocation
- , requireProgram, lookupProgram, ghcPkgProgram, lhcPkgProgram )
+ ( ProgramConfiguration, ConfiguredProgram
+ , runProgramInvocation, requireProgram, lookupProgram
+ , ghcPkgProgram, lhcPkgProgram )
import Distribution.Simple.Program.Script
( invocationAsSystemScript )
import qualified Distribution.Simple.Program.HcPkg as HcPkg
@@ -204,6 +206,14 @@ generateRegistrationInfo verbosity pkg lib lbi clbi inplace distPref = do
return installedPkgInfo{ IPI.installedPackageId = ipid }
+-- | Create an empty package DB at the specified location.
+initPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> FilePath
+ -> IO ()
+initPackageDB verbosity comp conf dbPath =
+ case (compilerFlavor comp) of
+ GHC -> GHC.initPackageDB verbosity conf dbPath
+ _ -> die "initPackageDB is not implemented for this compiler"
+
registerPackage :: Verbosity
-> InstalledPackageInfo
-> PackageDescription
View
26 Cabal/Distribution/Simple/Setup.hs
@@ -75,7 +75,7 @@ module Distribution.Simple.Setup (
BenchmarkFlags(..), emptyBenchmarkFlags, defaultBenchmarkFlags, benchmarkCommand,
CopyDest(..),
configureArgs, configureOptions, configureCCompiler, configureLinker,
- installDirsOptions,
+ buildOptions, installDirsOptions,
defaultDistPref,
@@ -1225,22 +1225,26 @@ defaultBuildFlags = BuildFlags {
}
buildCommand :: ProgramConfiguration -> CommandUI BuildFlags
-buildCommand progConf = makeCommand name shortDesc longDesc defaultBuildFlags options
+buildCommand progConf = makeCommand name shortDesc longDesc
+ defaultBuildFlags (buildOptions progConf)
where
name = "build"
shortDesc = "Make this package ready for installation."
longDesc = Nothing
- options showOrParseArgs =
- optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v })
- : optionDistPref
- buildDistPref (\d flags -> flags { buildDistPref = d })
- showOrParseArgs
- : programConfigurationPaths progConf showOrParseArgs
- buildProgramPaths (\v flags -> flags { buildProgramPaths = v})
+buildOptions :: ProgramConfiguration -> ShowOrParseArgs
+ -> [OptionField BuildFlags]
+buildOptions progConf showOrParseArgs =
+ optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v })
+ : optionDistPref
+ buildDistPref (\d flags -> flags { buildDistPref = d })
+ showOrParseArgs
+
+ : programConfigurationPaths progConf showOrParseArgs
+ buildProgramPaths (\v flags -> flags { buildProgramPaths = v})
- ++ programConfigurationOptions progConf showOrParseArgs
- buildProgramArgs (\v flags -> flags { buildProgramArgs = v})
+ ++ programConfigurationOptions progConf showOrParseArgs
+ buildProgramArgs (\v flags -> flags { buildProgramArgs = v})
emptyBuildFlags :: BuildFlags
emptyBuildFlags = mempty
View
2 cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs
@@ -5,7 +5,7 @@ module Distribution.Client.Dependency.Modular.PSQ where
-- I am not yet sure what exactly is needed. But we need a datastructure with
-- key-based lookup that can be sorted. We're using a sequence right now with
-- (inefficiently implemented) lookup, because I think that queue-based
--- opertions and sorting turn out to be more efficiency-critical in practice.
+-- operations and sorting turn out to be more efficiency-critical in practice.
import Control.Applicative
import Data.Foldable
View
4 cabal-install/Distribution/Client/Index.hs
@@ -29,7 +29,7 @@ import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString
, makeAbsoluteToCwd )
import Distribution.Simple.Setup ( fromFlagOrDefault )
-import Distribution.Simple.Utils ( die, debug, notice, warn, findPackageDesc )
+import Distribution.Simple.Utils ( die, debug, notice, findPackageDesc )
import Distribution.Verbosity ( Verbosity )
import qualified Data.ByteString.Lazy as BS
@@ -144,7 +144,7 @@ createEmpty :: Verbosity -> FilePath -> IO ()
createEmpty verbosity path = do
indexExists <- doesFileExist path
if indexExists
- then warn verbosity $ "package index already exists: '" ++ path ++ "'"
+ then debug verbosity $ "Package index already exists: " ++ path
else do
debug verbosity $ "Creating the index file '" ++ path ++ "'"
createDirectoryIfMissing True (takeDirectory path)
View
165 cabal-install/Distribution/Client/PackageEnvironment.hs
@@ -9,14 +9,17 @@
-----------------------------------------------------------------------------
module Distribution.Client.PackageEnvironment (
- PackageEnvironment(..),
- loadPackageEnvironment,
- showPackageEnvironment,
- showPackageEnvironmentWithComments,
-
- basePackageEnvironment,
- initialPackageEnvironment,
- commentPackageEnvironment
+ PackageEnvironment(..)
+ , loadOrCreatePackageEnvironment
+ , tryLoadPackageEnvironment
+ , readPackageEnvironmentFile
+ , showPackageEnvironment
+ , showPackageEnvironmentWithComments
+
+ , basePackageEnvironment
+ , initialPackageEnvironment
+ , commentPackageEnvironment
+ , defaultPackageEnvironmentFileName
) where
import Distribution.Client.Config ( SavedConfig(..), commentSavedConfig,
@@ -26,12 +29,13 @@ import Distribution.Client.Config ( SavedConfig(..), commentSavedConfig,
import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection )
import Distribution.Client.Setup ( GlobalFlags(..), ConfigExFlags(..)
, InstallFlags(..) )
-import Distribution.Simple.Compiler ( PackageDB(..) )
+import Distribution.Simple.Compiler ( Compiler, PackageDB(..)
+ , showCompilerId )
import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate,
toPathTemplate )
import Distribution.Simple.Setup ( Flag(..), ConfigFlags(..),
fromFlagOrDefault, toFlag )
-import Distribution.Simple.Utils ( notice, warn, lowercase )
+import Distribution.Simple.Utils ( die, notice, warn, lowercase )
import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..),
commaListField,
liftField, lineNo, locatedErrorMsg,
@@ -117,8 +121,8 @@ basePackageEnvironment pkgEnvDir = do
-- | Initial configuration that we write out to the package environment file if
-- it does not exist. When the package environment gets loaded it gets layered
-- on top of 'basePackageEnvironment'.
-initialPackageEnvironment :: FilePath -> IO PackageEnvironment
-initialPackageEnvironment pkgEnvDir = do
+initialPackageEnvironment :: FilePath -> Compiler -> IO PackageEnvironment
+initialPackageEnvironment pkgEnvDir compiler = do
initialConf' <- initialSavedConfig
let baseConf = commonPackageEnvironmentConfig pkgEnvDir
let initialConf = initialConf' `mappend` baseConf
@@ -127,18 +131,24 @@ initialPackageEnvironment pkgEnvDir = do
savedGlobalFlags = (savedGlobalFlags initialConf) {
globalLocalRepos = [pkgEnvDir </> "packages"]
},
- savedConfigureFlags = (savedConfigureFlags initialConf) {
- -- TODO: This should include comp. flavor and version
- configPackageDBs = [Just (SpecificPackageDB $ pkgEnvDir
- </> "packages.conf.d")]
- },
+ savedConfigureFlags = setPackageDB pkgEnvDir compiler
+ (savedConfigureFlags initialConf),
savedInstallFlags = (savedInstallFlags initialConf) {
installSummaryFile = [toPathTemplate (pkgEnvDir </>
"logs" </> "build.log")]
}
}
}
+-- | Use the package DB location specific for this compiler.
+setPackageDB :: FilePath -> Compiler -> ConfigFlags -> ConfigFlags
+setPackageDB pkgEnvDir compiler configFlags =
+ configFlags {
+ configPackageDBs = [Just (SpecificPackageDB $ pkgEnvDir
+ </> (showCompilerId compiler ++
+ "-packages.conf.d"))]
+ }
+
-- | Default values that get used if no value is given. Used here to include in
-- comments when we write out the initial package environment.
commentPackageEnvironment :: FilePath -> IO PackageEnvironment
@@ -149,43 +159,94 @@ commentPackageEnvironment pkgEnvDir = do
pkgEnvSavedConfig = commentConf `mappend` baseConf
}
--- | Load the package environment file, creating it if doesn't exist. Note that
--- the path parameter should be a name of an existing directory.
-loadPackageEnvironment :: Verbosity -> FilePath -> IO PackageEnvironment
-loadPackageEnvironment verbosity pkgEnvDir = do
+-- | Given a package environment loaded from a file, layer it on top of the base
+-- package environment.
+addBasePkgEnv :: Verbosity -> FilePath -> PackageEnvironment
+ -> IO PackageEnvironment
+addBasePkgEnv verbosity pkgEnvDir extra = do
+ let base = basePackageEnvironment pkgEnvDir
+ baseConf = pkgEnvSavedConfig base
+ -- Does this package environment inherit from some config file?
+ case pkgEnvInherit extra of
+ NoFlag ->
+ return $ base `mappend` extra
+ (Flag confPath) -> do
+ conf <- loadConfig verbosity (Flag confPath) NoFlag
+ let conf' = baseConf `mappend` conf `mappend` (pkgEnvSavedConfig extra)
+ return $ extra { pkgEnvSavedConfig = conf' }
+
+-- | Try to load a package environment file, exiting with error if it doesn't
+-- exist.
+tryLoadPackageEnvironment :: Verbosity -> FilePath -> IO PackageEnvironment
+tryLoadPackageEnvironment verbosity pkgEnvDir = do
let path = pkgEnvDir </> defaultPackageEnvironmentFileName
- addBasePkgEnv $ do
- minp <- readPackageEnvironmentFile mempty path
- case minp of
- Nothing -> do
- notice verbosity $ "Writing default package environment to " ++ path
- commentPkgEnv <- commentPackageEnvironment pkgEnvDir
- initialPkgEnv <- initialPackageEnvironment pkgEnvDir
- writePackageEnvironmentFile path commentPkgEnv initialPkgEnv
- return initialPkgEnv
- Just (ParseOk warns pkgEnv) -> do
- when (not $ null warns) $ warn verbosity $
- unlines (map (showPWarning path) warns)
- return pkgEnv
- Just (ParseFailed err) -> do
- let (line, msg) = locatedErrorMsg err
- warn verbosity $
- "Error parsing package environment file " ++ path
- ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg
- warn verbosity $ "Using default package environment."
- initialPackageEnvironment pkgEnvDir
+ minp <- readPackageEnvironmentFile mempty path
+ pkgEnv <- case minp of
+ Nothing -> die $
+ "The package environment file '" ++ path ++ "' doesn't exist"
+ Just (ParseOk warns parseResult) -> do
+ when (not $ null warns) $ warn verbosity $
+ unlines (map (showPWarning path) warns)
+ return parseResult
+ Just (ParseFailed err) -> do
+ let (line, msg) = locatedErrorMsg err
+ die $ "Error parsing package environment file " ++ path
+ ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg
+ addBasePkgEnv verbosity pkgEnvDir pkgEnv
+
+-- | Load a package environment file, creating one if it doesn't exist. Note
+-- that the path parameter should be a name of an existing directory.
+loadOrCreatePackageEnvironment :: Verbosity -> FilePath
+ -> ConfigFlags -> Compiler
+ -> IO PackageEnvironment
+loadOrCreatePackageEnvironment verbosity pkgEnvDir configFlags compiler = do
+ let path = pkgEnvDir </> defaultPackageEnvironmentFileName
+ minp <- readPackageEnvironmentFile mempty path
+ pkgEnv <- case minp of
+ Nothing -> do
+ notice verbosity $ "Writing default package environment to " ++ path
+ commentPkgEnv <- commentPackageEnvironment pkgEnvDir
+ initialPkgEnv <- initialPackageEnvironment pkgEnvDir compiler
+ let pkgEnv = updateConfigFlags initialPkgEnv
+ (\flags -> flags `mappend` configFlags)
+ writePackageEnvironmentFile path commentPkgEnv pkgEnv
+ return initialPkgEnv
+ Just (ParseOk warns parseResult) -> do
+ when (not $ null warns) $ warn verbosity $
+ unlines (map (showPWarning path) warns)
+
+ -- Update the package environment file in case the user has changed some
+ -- settings via the command-line (otherwise 'configure -w compiler-B' will
+ -- fail for a sandbox already configured to use compiler-A).
+ notice verbosity $ "Writing the updated package environment to " ++ path
+ commentPkgEnv <- commentPackageEnvironment pkgEnvDir
+ let pkgEnv = updateConfigFlags parseResult
+ (\flags ->
+ setPackageDB pkgEnvDir compiler flags
+ `mappend` configFlags)
+ writePackageEnvironmentFile path commentPkgEnv pkgEnv
+
+ return pkgEnv
+ Just (ParseFailed err) -> do
+ let (line, msg) = locatedErrorMsg err
+ warn verbosity $
+ "Error parsing package environment file " ++ path
+ ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg
+ warn verbosity $ "Using default package environment."
+ initialPackageEnvironment pkgEnvDir compiler
+ addBasePkgEnv verbosity pkgEnvDir pkgEnv
+
where
- addBasePkgEnv :: IO PackageEnvironment -> IO PackageEnvironment
- addBasePkgEnv body = do
- let base = basePackageEnvironment pkgEnvDir
- extra <- body
- case pkgEnvInherit extra of
- NoFlag ->
- return $ base `mappend` extra
- (Flag confPath) -> do
- conf <- loadConfig verbosity (Flag confPath) (Flag False)
- let conf' = base `mappend` conf `mappend` (pkgEnvSavedConfig extra)
- return $ extra { pkgEnvSavedConfig = conf' }
+ updateConfigFlags :: PackageEnvironment -> (ConfigFlags -> ConfigFlags)
+ -> PackageEnvironment
+ updateConfigFlags pkgEnv f =
+ let pkgEnvConfig = pkgEnvSavedConfig pkgEnv
+ pkgEnvConfigFlags = savedConfigureFlags pkgEnvConfig
+ in pkgEnv {
+ pkgEnvSavedConfig = pkgEnvConfig {
+ savedConfigureFlags = f pkgEnvConfigFlags
+ }
+ }
-- | Descriptions of all fields in the package environment file.
pkgEnvFieldDescrs :: [FieldDescr PackageEnvironment]
View
215 cabal-install/Distribution/Client/Sandbox.hs
@@ -0,0 +1,215 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.Sandbox
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- UI for the sandboxing functionality.
+-----------------------------------------------------------------------------
+
+module Distribution.Client.Sandbox (
+ dumpPackageEnvironment,
+
+ sandboxAddSource,
+ sandboxConfigure,
+ sandboxBuild,
+ sandboxInstall
+ ) where
+
+import Distribution.Client.Setup
+ ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), GlobalFlags(..)
+ , InstallFlags(..), globalRepos
+ , defaultInstallFlags, defaultConfigExFlags, defaultSandboxLocation
+ , installCommand )
+import Distribution.Client.Config ( SavedConfig(..), loadConfig )
+import Distribution.Client.Configure ( configure )
+import Distribution.Client.Install ( install )
+import Distribution.Client.PackageEnvironment
+ ( PackageEnvironment(..)
+ , loadOrCreatePackageEnvironment, tryLoadPackageEnvironment
+ , commentPackageEnvironment
+ , showPackageEnvironmentWithComments, readPackageEnvironmentFile
+ , basePackageEnvironment, defaultPackageEnvironmentFileName )
+import Distribution.Client.SetupWrapper
+ ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
+import Distribution.Client.Targets ( readUserTargets )
+import Distribution.Simple.Compiler ( Compiler
+ , PackageDB(..), PackageDBStack )
+import Distribution.Simple.Configure ( configCompilerAux
+ , interpretPackageDbFlags )
+import Distribution.Simple.Program ( ProgramConfiguration
+ , defaultProgramConfiguration )
+import Distribution.Simple.Setup ( Flag(..), toFlag
+ , BuildFlags(..), HaddockFlags(..)
+ , buildCommand, fromFlagOrDefault )
+import Distribution.Simple.Utils ( die, notice
+ , createDirectoryIfMissingVerbose )
+import Distribution.ParseUtils ( ParseResult(..) )
+import Distribution.Verbosity ( Verbosity, lessVerbose )
+import qualified Distribution.Client.Index as Index
+import qualified Distribution.Simple.Register as Register
+import Control.Monad ( unless, when )
+import Data.Monoid ( mappend, mempty )
+import System.Directory ( canonicalizePath
+ , doesDirectoryExist
+ , doesFileExist )
+import System.FilePath ( (</>) )
+
+
+-- | Given a 'SandboxFlags' record, return a canonical path to the
+-- sandbox. Exits with error if the sandbox directory does not exist or is not
+-- properly initialised.
+getSandboxLocation :: Verbosity -> SandboxFlags -> IO FilePath
+getSandboxLocation verbosity sandboxFlags = do
+ let sandboxDir' = fromFlagOrDefault defaultSandboxLocation
+ (sandboxLocation sandboxFlags)
+ sandboxDir <- canonicalizePath sandboxDir'
+ dirExists <- doesDirectoryExist sandboxDir
+ pkgEnvExists <- doesFileExist $
+ sandboxDir </> defaultPackageEnvironmentFileName
+ unless (dirExists && pkgEnvExists) $
+ die ("No sandbox exists at " ++ sandboxDir)
+ notice verbosity $ "Using a sandbox located at " ++ sandboxDir
+ return sandboxDir
+
+-- | Return the name of the package index file for this package environment.
+getIndexFilePath :: PackageEnvironment -> IO FilePath
+getIndexFilePath pkgEnv = do
+ let paths = globalLocalRepos . savedGlobalFlags . pkgEnvSavedConfig $ pkgEnv
+ case paths of
+ [] -> die $ "Distribution.Client.Sandbox.getIndexFilePath: " ++
+ "no local repos found"
+ [p] -> return $ p </> Index.defaultIndexFileName
+ _ -> die $ "Distribution.Client.Sandbox.getIndexFilePath: " ++
+ "too many local repos found"
+
+-- | Entry point for the 'cabal dump-pkgenv' command.
+dumpPackageEnvironment :: Verbosity -> SandboxFlags -> IO ()
+dumpPackageEnvironment verbosity sandboxFlags = do
+ pkgEnvDir <- getSandboxLocation verbosity sandboxFlags
+
+ pkgEnv <- tryLoadPackageEnvironment verbosity pkgEnvDir
+ commentPkgEnv <- commentPackageEnvironment pkgEnvDir
+ putStrLn . showPackageEnvironmentWithComments commentPkgEnv $ pkgEnv
+
+-- | Entry point for the 'cabal sandbox-configure' command.
+sandboxConfigure :: Verbosity -> SandboxFlags -> ConfigFlags -> ConfigExFlags
+ -> [String] -> GlobalFlags -> IO ()
+sandboxConfigure verbosity
+ sandboxFlags configFlags configExFlags extraArgs globalFlags = do
+ let sandboxDir' = fromFlagOrDefault defaultSandboxLocation
+ (sandboxLocation sandboxFlags)
+ createDirectoryIfMissingVerbose verbosity True sandboxDir'
+ sandboxDir <- canonicalizePath sandboxDir'
+ (comp, conf) <- configCompilerSandbox sandboxDir
+ notice verbosity $ "Using a sandbox located at " ++ sandboxDir
+
+ pkgEnv <- loadOrCreatePackageEnvironment verbosity sandboxDir configFlags comp
+
+ let config = pkgEnvSavedConfig pkgEnv
+ configFlags' = savedConfigureFlags config `mappend` configFlags
+ configExFlags' = savedConfigureExFlags config `mappend` configExFlags
+ globalFlags' = savedGlobalFlags config `mappend` globalFlags
+ [Just (SpecificPackageDB dbPath)]
+ = configPackageDBs configFlags'
+
+ indexFile <- getIndexFilePath pkgEnv
+ Index.createEmpty verbosity indexFile
+ packageDBExists <- doesDirectoryExist dbPath
+ unless packageDBExists $
+ Register.initPackageDB verbosity comp conf dbPath
+ when packageDBExists $
+ notice verbosity $ "The package database already exists: " ++ dbPath
+ configure verbosity
+ (configPackageDB' configFlags') (globalRepos globalFlags')
+ comp conf configFlags' configExFlags' extraArgs
+ where
+ -- We need to know the compiler version so that the correct package DB is
+ -- used. We try to read it from the package environment file, which might
+ -- not exist.
+ configCompilerSandbox :: FilePath -> IO (Compiler, ProgramConfiguration)
+ configCompilerSandbox sandboxDir = do
+ -- Build a ConfigFlags record...
+ let basePkgEnv = basePackageEnvironment sandboxDir
+ userConfig <- loadConfig verbosity NoFlag NoFlag
+ mPkgEnv <- readPackageEnvironmentFile mempty
+ (sandboxDir </> defaultPackageEnvironmentFileName)
+ let pkgEnv = case mPkgEnv of
+ Just (ParseOk _warns parseResult) -> parseResult
+ _ -> mempty
+ let basePkgEnvConfig = pkgEnvSavedConfig basePkgEnv
+ pkgEnvConfig = pkgEnvSavedConfig pkgEnv
+ configFlags' = savedConfigureFlags basePkgEnvConfig
+ `mappend` savedConfigureFlags userConfig
+ `mappend` savedConfigureFlags pkgEnvConfig
+ `mappend` configFlags
+ -- ...and pass it to configCompilerAux.
+ configCompilerAux configFlags'
+
+-- | Entry point for the 'cabal sandbox-add-source' command.
+sandboxAddSource :: Verbosity -> SandboxFlags -> [FilePath] -> IO ()
+sandboxAddSource verbosity sandboxFlags buildTreeRefs = do
+ sandboxDir <- getSandboxLocation verbosity sandboxFlags
+ pkgEnv <- tryLoadPackageEnvironment verbosity sandboxDir
+ indexFile <- getIndexFilePath pkgEnv
+ Index.addBuildTreeRefs verbosity indexFile buildTreeRefs
+
+-- | Entry point for the 'cabal sandbox-build' command.
+sandboxBuild :: Verbosity -> SandboxFlags -> BuildFlags -> [String] -> IO ()
+sandboxBuild verbosity sandboxFlags buildFlags' extraArgs = do
+ -- Check that the sandbox exists.
+ _ <- getSandboxLocation verbosity sandboxFlags
+
+ let setupScriptOptions = defaultSetupScriptOptions {
+ useDistPref = fromFlagOrDefault
+ (useDistPref defaultSetupScriptOptions)
+ (buildDistPref buildFlags)
+ }
+ buildFlags = buildFlags' {
+ buildVerbosity = toFlag verbosity
+ }
+ setupWrapper verbosity setupScriptOptions Nothing
+ (buildCommand defaultProgramConfiguration) (const buildFlags) extraArgs
+
+-- | Entry point for the 'cabal sandbox-install' command.
+sandboxInstall :: Verbosity -> SandboxFlags -> ConfigFlags -> ConfigExFlags
+ -> InstallFlags -> HaddockFlags -> [String] -> GlobalFlags
+ -> IO ()
+sandboxInstall verbosity _sandboxFlags _configFlags _configExFlags
+ installFlags _haddockFlags _extraArgs _globalFlags
+ | fromFlagOrDefault False (installOnly installFlags)
+ = setupWrapper verbosity defaultSetupScriptOptions Nothing
+ installCommand (const mempty) []
+
+sandboxInstall verbosity sandboxFlags configFlags configExFlags
+ installFlags haddockFlags extraArgs globalFlags = do
+ sandboxDir <- getSandboxLocation verbosity sandboxFlags
+
+ pkgEnv <- tryLoadPackageEnvironment verbosity sandboxDir
+ targets <- readUserTargets verbosity extraArgs
+ let config = pkgEnvSavedConfig pkgEnv
+ configFlags' = savedConfigureFlags config `mappend` configFlags
+ configExFlags' = defaultConfigExFlags `mappend`
+ savedConfigureExFlags config `mappend` configExFlags
+ installFlags' = defaultInstallFlags `mappend`
+ savedInstallFlags config `mappend` installFlags
+ globalFlags' = savedGlobalFlags config `mappend` globalFlags
+ (comp, conf) <- configCompilerAux' configFlags'
+ install verbosity
+ (configPackageDB' configFlags') (globalRepos globalFlags')
+ comp conf
+ globalFlags' configFlags' configExFlags' installFlags' haddockFlags
+ targets
+
+configPackageDB' :: ConfigFlags -> PackageDBStack
+configPackageDB' cfg =
+ interpretPackageDbFlags userInstall (configPackageDBs cfg)
+ where
+ userInstall = fromFlagOrDefault True (configUserInstall cfg)
+
+configCompilerAux' :: ConfigFlags
+ -> IO (Compiler, ProgramConfiguration)
+configCompilerAux' configFlags =
+ configCompilerAux configFlags
+ --FIXME: make configCompilerAux use a sensible verbosity
+ { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }
View
158 cabal-install/Distribution/Client/Setup.hs
@@ -30,6 +30,9 @@ module Distribution.Client.Setup
, sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
, win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
, indexCommand, IndexFlags(..)
+ , dumpPkgEnvCommand, sandboxConfigureCommand, sandboxAddSourceCommand
+ , sandboxBuildCommand, sandboxInstallCommand, defaultSandboxLocation
+ , SandboxFlags(..)
, parsePackageArgs
--TODO: stop exporting these:
@@ -52,7 +55,8 @@ import Distribution.Simple.Program
( defaultProgramConfiguration )
import Distribution.Simple.Command hiding (boolOpt)
import qualified Distribution.Simple.Setup as Cabal
- ( configureCommand, buildCommand, sdistCommand, haddockCommand )
+ ( configureCommand, buildCommand, sdistCommand, haddockCommand
+ , buildOptions, defaultBuildFlags )
import Distribution.Simple.Setup
( ConfigFlags(..), BuildFlags(..), SDistFlags(..), HaddockFlags(..) )
import Distribution.Simple.Setup
@@ -699,18 +703,19 @@ installCommand = CommandUI {
get3 (_,_,c,_) = c; set3 c (a,b,_,d) = (a,b,c,d)
get4 (_,_,_,d) = d; set4 d (a,b,c,_) = (a,b,c,d)
- haddockOptions showOrParseArgs
- = [ opt { optionName = "haddock-" ++ name,
- optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr
- | descr <- optionDescr opt] }
- | opt <- commandOptions Cabal.haddockCommand showOrParseArgs
- , let name = optionName opt
- , name `elem` ["hoogle", "html", "html-location",
- "executables", "internal", "css",
- "hyperlink-source", "hscolour-css",
- "contents-location"]
- ]
-
+haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags]
+haddockOptions showOrParseArgs
+ = [ opt { optionName = "haddock-" ++ name,
+ optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr
+ | descr <- optionDescr opt] }
+ | opt <- commandOptions Cabal.haddockCommand showOrParseArgs
+ , let name = optionName opt
+ , name `elem` ["hoogle", "html", "html-location",
+ "executables", "internal", "css",
+ "hyperlink-source", "hscolour-css",
+ "contents-location"]
+ ]
+ where
fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a
fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w
fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w
@@ -1254,6 +1259,128 @@ instance Monoid IndexFlags where
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
+-- * Sandbox-related flags
+-- ------------------------------------------------------------
+
+data SandboxFlags = SandboxFlags {
+ sandboxVerbosity :: Flag Verbosity,
+ sandboxLocation :: Flag FilePath
+}
+
+defaultSandboxLocation :: FilePath
+defaultSandboxLocation = ".cabal-sandbox"
+
+defaultSandboxFlags :: SandboxFlags
+defaultSandboxFlags = SandboxFlags {
+ sandboxVerbosity = toFlag normal,
+ sandboxLocation = toFlag defaultSandboxLocation
+ }
+
+commonSandboxOptions :: ShowOrParseArgs -> [OptionField SandboxFlags]
+commonSandboxOptions _showOrParseArgs =
+ [ optionVerbosity sandboxVerbosity (\v flags -> flags { sandboxVerbosity = v })
+
+ , option [] ["sandbox"]
+ "Sandbox location (default: './.cabal-sandbox')."
+ sandboxLocation (\v flags -> flags { sandboxLocation = v })
+ (reqArgFlag "DIR")
+ ]
+
+sandboxConfigureCommand :: CommandUI (SandboxFlags, ConfigFlags, ConfigExFlags)
+sandboxConfigureCommand = CommandUI {
+ commandName = "sandbox-configure",
+ commandSynopsis = "Configure a package inside a sandbox",
+ commandDescription = Nothing,
+ commandUsage = \pname -> usageFlags pname "sandbox-configure",
+ commandDefaultFlags = (defaultSandboxFlags, mempty, defaultConfigExFlags),
+ commandOptions = \showOrParseArgs ->
+ liftOptions get1 set1 (commonSandboxOptions showOrParseArgs)
+ ++ liftOptions get2 set2
+ (filter ((\n -> n /= "constraint" && n /= "verbose") . optionName) $
+ configureOptions showOrParseArgs)
+ ++ liftOptions get3 set3 (configureExOptions showOrParseArgs)
+
+ }
+ where
+ get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)
+ get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)
+ get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c)
+
+sandboxAddSourceCommand :: CommandUI SandboxFlags
+sandboxAddSourceCommand = CommandUI {
+ commandName = "sandbox-add-source",
+ commandSynopsis = "Make a source package available in a sandbox",
+ commandDescription = Nothing,
+ commandUsage = \pname -> usageFlags pname "sandbox-add-source",
+ commandDefaultFlags = defaultSandboxFlags,
+ commandOptions = commonSandboxOptions
+ }
+
+sandboxBuildCommand :: CommandUI (SandboxFlags, BuildFlags)
+sandboxBuildCommand = CommandUI {
+ commandName = "sandbox-build",
+ commandSynopsis = "Build a package inside a sandbox",
+ commandDescription = Nothing,
+ commandUsage = \pname -> usageFlags pname "sandbox-build",
+ commandDefaultFlags = (defaultSandboxFlags, Cabal.defaultBuildFlags),
+ commandOptions = \showOrParseArgs ->
+ liftOptions fst setFst (commonSandboxOptions showOrParseArgs)
+ ++ liftOptions snd setSnd (filter ((/= "verbose") . optionName) $
+ Cabal.buildOptions progConf showOrParseArgs)
+ }
+ where
+ progConf = defaultProgramConfiguration
+
+ setFst a (_,b) = (a,b)
+ setSnd b (a,_) = (a,b)
+
+sandboxInstallCommand :: CommandUI (SandboxFlags, ConfigFlags, ConfigExFlags,
+ InstallFlags, HaddockFlags)
+sandboxInstallCommand = CommandUI {
+ commandName = "sandbox-install",
+ commandSynopsis = "Install a list of packages into a sandbox",
+ commandDescription = commandDescription installCommand,
+ commandUsage = \pname -> usagePackages pname "sandbox-install",
+ commandDefaultFlags = (defaultSandboxFlags, mempty, mempty, mempty, mempty),
+ commandOptions = \showOrParseArgs ->
+ liftOptions get1 set1 (commonSandboxOptions showOrParseArgs)
+ ++ liftOptions get2 set2
+ (filter ((\n -> n /= "constraint" && n /= "verbose") . optionName) $
+ configureOptions showOrParseArgs)
+ ++ liftOptions get3 set3 (configureExOptions showOrParseArgs)
+ ++ liftOptions get4 set4 (installOptions showOrParseArgs)
+ ++ liftOptions get5 set5 (haddockOptions showOrParseArgs)
+ }
+ where
+ get1 (a,_,_,_,_) = a; set1 a (_,b,c,d,e) = (a,b,c,d,e)
+ get2 (_,b,_,_,_) = b; set2 b (a,_,c,d,e) = (a,b,c,d,e)
+ get3 (_,_,c,_,_) = c; set3 c (a,b,_,d,e) = (a,b,c,d,e)
+ get4 (_,_,_,d,_) = d; set4 d (a,b,c,_,e) = (a,b,c,d,e)
+ get5 (_,_,_,_,e) = e; set5 e (a,b,c,d,_) = (a,b,c,d,e)
+
+dumpPkgEnvCommand :: CommandUI SandboxFlags
+dumpPkgEnvCommand = CommandUI {
+ commandName = "dump-pkgenv",
+ commandSynopsis = "Dump a parsed package environment file",
+ commandDescription = Nothing,
+ commandUsage = \pname -> usageFlags pname "dump-pkgenv",
+ commandDefaultFlags = defaultSandboxFlags,
+ commandOptions = commonSandboxOptions
+ }
+
+instance Monoid SandboxFlags where
+ mempty = SandboxFlags {
+ sandboxVerbosity = mempty,
+ sandboxLocation = mempty
+ }
+ mappend a b = SandboxFlags {
+ sandboxVerbosity = combine sandboxVerbosity,
+ sandboxLocation = combine sandboxLocation
+ }
+ where combine field = field a `mappend` field b
+
+
+-- ------------------------------------------------------------
-- * GetOpt Utils
-- ------------------------------------------------------------
@@ -1317,6 +1444,11 @@ usagePackages name pname =
++ " or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"
++ "Flags for " ++ name ++ ":"
+usageFlags :: String -> String -> String
+usageFlags name pname =
+ "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"
+ ++ "Flags for " ++ name ++ ":"
+
--TODO: do we want to allow per-package flags?
parsePackageArgs :: [String] -> Either String [Dependency]
parsePackageArgs = parsePkgArgs []
View
2 cabal-install/Distribution/Client/Tar.hs
@@ -388,7 +388,7 @@ splitLongPath path =
where n' = n + length c
packName' _ _ ok cs = (FilePath.Posix.joinPath ok, cs)
--- | The tar format allows just 100 ASCII charcters for the 'SymbolicLink' and
+-- | The tar format allows just 100 ASCII characters for the 'SymbolicLink' and
-- 'HardLink' entry types.
--
newtype LinkTarget = LinkTarget FilePath
View
78 cabal-install/Main.hs
@@ -31,6 +31,9 @@ import Distribution.Client.Setup
, SDistFlags(..), SDistExFlags(..), sdistCommand
, Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand
, IndexFlags(..), indexCommand
+ , SandboxFlags(..), sandboxAddSourceCommand
+ , sandboxConfigureCommand, sandboxBuildCommand, sandboxInstallCommand
+ , dumpPkgEnvCommand
, reportCommand
, unpackCommand, UnpackFlags(..) )
import Distribution.Simple.Setup
@@ -50,18 +53,22 @@ import Distribution.Client.Config
import Distribution.Client.Targets
( readUserTargets )
-import Distribution.Client.List (list, info)
-import Distribution.Client.Install (install, upgrade)
-import Distribution.Client.Configure (configure)
-import Distribution.Client.Update (update)
-import Distribution.Client.Fetch (fetch)
-import Distribution.Client.Check as Check (check)
+import Distribution.Client.List (list, info)
+import Distribution.Client.Install (install, upgrade)
+import Distribution.Client.Configure (configure)
+import Distribution.Client.Update (update)
+import Distribution.Client.Fetch (fetch)
+import Distribution.Client.Check as Check (check)
--import Distribution.Client.Clean (clean)
-import Distribution.Client.Upload as Upload (upload, check, report)
-import Distribution.Client.SrcDist (sdist)
-import Distribution.Client.Unpack (unpack)
-import Distribution.Client.Index (index)
-import Distribution.Client.Init (initCabal)
+import Distribution.Client.Upload as Upload (upload, check, report)
+import Distribution.Client.SrcDist (sdist)
+import Distribution.Client.Unpack (unpack)
+import Distribution.Client.Index (index)
+import Distribution.Client.Sandbox (sandboxConfigure
+ , sandboxAddSource, sandboxBuild
+ , sandboxInstall
+ , dumpPackageEnvironment)
+import Distribution.Client.Init (initCabal)
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import Distribution.Simple.Compiler
@@ -159,6 +166,16 @@ mainWorker args = topHandler $
win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction
,hiddenCommand $
indexCommand `commandAddAction` indexAction
+ ,hiddenCommand $
+ sandboxConfigureCommand `commandAddAction` sandboxConfigureAction
+ ,hiddenCommand $
+ sandboxAddSourceCommand `commandAddAction` sandboxAddSourceAction
+ ,hiddenCommand $
+ sandboxBuildCommand `commandAddAction` sandboxBuildAction
+ ,hiddenCommand $
+ sandboxInstallCommand `commandAddAction` sandboxInstallAction
+ ,hiddenCommand $
+ dumpPkgEnvCommand `commandAddAction` dumpPkgEnvAction
]
wrapperAction :: Monoid flags
@@ -557,12 +574,49 @@ initAction initFlags _extraArgs globalFlags = do
indexAction :: IndexFlags -> [String] -> GlobalFlags -> IO ()
indexAction indexFlags extraArgs _globalFlags = do
when (null extraArgs) $ do
- die $ "the 'index' command expects a single argument. "
+ die $ "the 'index' command expects a single argument."
when ((>1). length $ extraArgs) $ do
die $ "the 'index' command expects a single argument: " ++ unwords extraArgs
let verbosity = fromFlag (indexVerbosity indexFlags)
index verbosity indexFlags (head extraArgs)
+sandboxConfigureAction :: (SandboxFlags, ConfigFlags, ConfigExFlags)
+ -> [String] -> GlobalFlags -> IO ()
+sandboxConfigureAction (sandboxFlags, configFlags, configExFlags)
+ extraArgs globalFlags = do
+ let verbosity = fromFlag (sandboxVerbosity sandboxFlags)
+ sandboxConfigure verbosity sandboxFlags configFlags configExFlags
+ extraArgs globalFlags
+
+sandboxAddSourceAction :: SandboxFlags -> [String] -> GlobalFlags -> IO ()
+sandboxAddSourceAction sandboxFlags extraArgs _globalFlags = do
+ let verbosity = fromFlag (sandboxVerbosity sandboxFlags)
+ sandboxAddSource verbosity sandboxFlags extraArgs
+
+sandboxBuildAction :: (SandboxFlags, BuildFlags) -> [String] -> GlobalFlags
+ -> IO ()
+sandboxBuildAction (sandboxFlags, buildFlags) extraArgs _globalFlags = do
+ let verbosity = fromFlag (sandboxVerbosity sandboxFlags)
+ sandboxBuild verbosity sandboxFlags buildFlags extraArgs
+
+sandboxInstallAction :: (SandboxFlags, ConfigFlags, ConfigExFlags,
+ InstallFlags, HaddockFlags)
+ -> [String] -> GlobalFlags -> IO ()
+sandboxInstallAction
+ (sandboxFlags, configFlags, configExFlags, installFlags, haddockFlags)
+ extraArgs globalFlags = do
+ let verbosity = fromFlag (sandboxVerbosity sandboxFlags)
+ sandboxInstall verbosity sandboxFlags configFlags configExFlags
+ installFlags haddockFlags extraArgs globalFlags
+
+dumpPkgEnvAction :: SandboxFlags -> [String] -> GlobalFlags -> IO ()
+dumpPkgEnvAction sandboxFlags extraArgs _globalFlags = do
+ when ((>0). length $ extraArgs) $ do
+ die $ "the 'dump-pkgenv' command doesn't expect any arguments: "
+ ++ unwords extraArgs
+ let verbosity = fromFlag (sandboxVerbosity sandboxFlags)
+ dumpPackageEnvironment verbosity sandboxFlags
+
-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.
--
win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> GlobalFlags
Something went wrong with that request. Please try again.