Skip to content
Browse files

Implement the preliminary sandbox UI.

Adds five new hidden commands:

    cabal sandbox-configure
    cabal sandbox-add-source
    cabal sandbox-build
    cabal sandbox-install
    cabal dump-pkgenv
  • Loading branch information...
1 parent c3cb22b commit d8fcb94ce9ccfa2b922a007df9a67038e01b6487 @23Skidoo 23Skidoo committed Aug 25, 2012
View
166 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,44 +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
- baseConf = pkgEnvSavedConfig base
- extra <- body
- case pkgEnvInherit extra of
- NoFlag ->
- return $ base `mappend` extra
- (Flag confPath) -> do
- conf <- loadConfig verbosity (Flag confPath) (Flag False)
- let conf' = baseConf `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
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

0 comments on commit d8fcb94

Please sign in to comment.
Something went wrong with that request. Please try again.