1{-# LANGUAGE CPP #-} 2 3----------------------------------------------------------------------------- 4-- | 5-- Module : Main 6-- Copyright : (c) David Himmelstrup 2005 7-- License : BSD-like 8-- 9-- Maintainer : lemmih@gmail.com 10-- Stability : provisional 11-- Portability : portable 12-- 13-- Entry point to the default cabal-install front-end. 14----------------------------------------------------------------------------- 15 16module Main (main) where 17 18import Distribution.Client.Setup 19 ( GlobalFlags(..), globalCommand, withRepoContext 20 , ConfigFlags(..) 21 , ConfigExFlags(..), defaultConfigExFlags, configureExCommand 22 , reconfigureCommand 23 , configCompilerAux', configPackageDB' 24 , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) 25 , buildCommand, replCommand, testCommand, benchmarkCommand 26 , InstallFlags(..), defaultInstallFlags 27 , installCommand, upgradeCommand, uninstallCommand 28 , FetchFlags(..), fetchCommand 29 , FreezeFlags(..), freezeCommand 30 , genBoundsCommand 31 , OutdatedFlags(..), outdatedCommand 32 , GetFlags(..), getCommand, unpackCommand 33 , checkCommand 34 , formatCommand 35 , UpdateFlags(..), updateCommand 36 , ListFlags(..), listCommand 37 , InfoFlags(..), infoCommand 38 , UploadFlags(..), uploadCommand 39 , ReportFlags(..), reportCommand 40 , runCommand 41 , InitFlags(initVerbosity, initHcPath), initCommand 42 , SDistFlags(..), sdistCommand 43 , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand 44 , ActAsSetupFlags(..), actAsSetupCommand 45 , SandboxFlags(..), sandboxCommand 46 , ExecFlags(..), execCommand 47 , UserConfigFlags(..), userConfigCommand 48 , reportCommand 49 , manpageCommand 50 , haddockCommand 51 , cleanCommand 52 , doctestCommand 53 , copyCommand 54 , registerCommand 55 ) 56import Distribution.Simple.Setup 57 ( HaddockTarget(..) 58 , DoctestFlags(..) 59 , HaddockFlags(..), defaultHaddockFlags 60 , HscolourFlags(..), hscolourCommand 61 , ReplFlags(..) 62 , CopyFlags(..) 63 , RegisterFlags(..) 64 , CleanFlags(..) 65 , TestFlags(..), BenchmarkFlags(..) 66 , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag 67 , configAbsolutePaths 68 ) 69 70import Prelude () 71import Distribution.Solver.Compat.Prelude hiding (get) 72 73import Distribution.Client.SetupWrapper 74 ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) 75import Distribution.Client.Config 76 ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff 77 , userConfigUpdate, createDefaultConfigFile, getConfigFilePath ) 78import Distribution.Client.Targets 79 ( readUserTargets ) 80import qualified Distribution.Client.List as List 81 ( list, info ) 82 83import qualified Distribution.Client.CmdConfigure as CmdConfigure 84import qualified Distribution.Client.CmdUpdate as CmdUpdate 85import qualified Distribution.Client.CmdBuild as CmdBuild 86import qualified Distribution.Client.CmdRepl as CmdRepl 87import qualified Distribution.Client.CmdFreeze as CmdFreeze 88import qualified Distribution.Client.CmdHaddock as CmdHaddock 89import qualified Distribution.Client.CmdInstall as CmdInstall 90import qualified Distribution.Client.CmdRun as CmdRun 91import qualified Distribution.Client.CmdTest as CmdTest 92import qualified Distribution.Client.CmdBench as CmdBench 93import qualified Distribution.Client.CmdExec as CmdExec 94import qualified Distribution.Client.CmdClean as CmdClean 95import qualified Distribution.Client.CmdSdist as CmdSdist 96import Distribution.Client.CmdLegacy 97 98import Distribution.Client.Install (install) 99import Distribution.Client.Configure (configure, writeConfigFlags) 100import Distribution.Client.Update (update) 101import Distribution.Client.Exec (exec) 102import Distribution.Client.Fetch (fetch) 103import Distribution.Client.Freeze (freeze) 104import Distribution.Client.GenBounds (genBounds) 105import Distribution.Client.Outdated (outdated) 106import Distribution.Client.Check as Check (check) 107--import Distribution.Client.Clean (clean) 108import qualified Distribution.Client.Upload as Upload 109import Distribution.Client.Run (run, splitRunArgs) 110import Distribution.Client.SrcDist (sdist) 111import Distribution.Client.Get (get) 112import Distribution.Client.Reconfigure (Check(..), reconfigure) 113import Distribution.Client.Nix (nixInstantiate 114 ,nixShell 115 ,nixShellIfSandboxed) 116import Distribution.Client.Sandbox (sandboxInit 117 ,sandboxAddSource 118 ,sandboxDelete 119 ,sandboxDeleteSource 120 ,sandboxListSources 121 ,sandboxHcPkg 122 ,dumpPackageEnvironment 123 124 ,loadConfigOrSandboxConfig 125 ,findSavedDistPref 126 ,initPackageDBIfNeeded 127 ,maybeWithSandboxDirOnSearchPath 128 ,maybeWithSandboxPackageInfo 129 ,tryGetIndexFilePath 130 ,sandboxBuildDir 131 ,updateSandboxConfigFileFlag 132 ,updateInstallDirs 133 134 ,getPersistOrConfigCompiler) 135import Distribution.Client.Sandbox.PackageEnvironment (setPackageDB) 136import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord) 137import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox) 138import Distribution.Client.Tar (createTarGzFile) 139import Distribution.Client.Types (Password (..)) 140import Distribution.Client.Init (initCabal) 141import Distribution.Client.Manpage (manpage) 142import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade 143import Distribution.Client.Utils (determineNumJobs 144 ,relaxEncodingErrors 145 ) 146 147import Distribution.Package (packageId) 148import Distribution.PackageDescription 149 ( BuildType(..), Executable(..), buildable ) 150import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) 151 152import Distribution.PackageDescription.PrettyPrint 153 ( writeGenericPackageDescription ) 154import qualified Distribution.Simple as Simple 155import qualified Distribution.Make as Make 156import qualified Distribution.Types.UnqualComponentName as Make 157import Distribution.Simple.Build 158 ( startInterpreter ) 159import Distribution.Simple.Command 160 ( CommandParse(..), CommandUI(..), Command, CommandSpec(..) 161 , CommandType(..), commandsRun, commandAddAction, hiddenCommand 162 , commandFromSpec, commandShowOptions ) 163import Distribution.Simple.Compiler (Compiler(..), PackageDBStack) 164import Distribution.Simple.Configure 165 ( configCompilerAuxEx, ConfigStateFileError(..) 166 , getPersistBuildConfig, interpretPackageDbFlags 167 , tryGetPersistBuildConfig ) 168import qualified Distribution.Simple.LocalBuildInfo as LBI 169import Distribution.Simple.Program (defaultProgramDb 170 ,configureAllKnownPrograms 171 ,simpleProgramInvocation 172 ,getProgramInvocationOutput) 173import Distribution.Simple.Program.Db (reconfigurePrograms) 174import qualified Distribution.Simple.Setup as Cabal 175import Distribution.Simple.Utils 176 ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler 177 , findPackageDesc, tryFindPackageDesc ) 178import Distribution.Text 179 ( display ) 180import Distribution.Verbosity as Verbosity 181 ( Verbosity, normal ) 182import Distribution.Version 183 ( Version, mkVersion, orLaterVersion ) 184import qualified Paths_cabal_install (version) 185 186import Distribution.Compat.ResponseFile 187import System.Environment (getArgs, getProgName) 188import System.Exit (exitFailure, exitSuccess) 189import System.FilePath ( dropExtension, splitExtension 190 , takeExtension, (</>), (<.>) ) 191import System.IO ( BufferMode(LineBuffering), hSetBuffering 192 , stderr, stdout ) 193import System.Directory (doesFileExist, getCurrentDirectory) 194import Data.Monoid (Any(..)) 195import Control.Exception (SomeException(..), try) 196import Control.Monad (mapM_) 197import Data.Version (showVersion) 198 199#ifdef MONOLITHIC 200import qualified UnitTests 201import qualified MemoryUsageTests 202import qualified SolverQuickCheck 203import qualified IntegrationTests2 204import qualified System.Environment as Monolithic 205#endif 206 207-- | Entry point 208-- 209main :: IO () 210#ifdef MONOLITHIC 211main = do 212 mb_exec <- Monolithic.lookupEnv "CABAL_INSTALL_MONOLITHIC_MODE" 213 case mb_exec of 214 Just "UnitTests" -> UnitTests.main 215 Just "MemoryUsageTests" -> MemoryUsageTests.main 216 Just "SolverQuickCheck" -> SolverQuickCheck.main 217 Just "IntegrationTests2" -> IntegrationTests2.main 218 Just s -> error $ "Unrecognized mode '" ++ show s ++ "' in CABAL_INSTALL_MONOLITHIC_MODE" 219 Nothing -> main' 220#else 221main = main' 222#endif 223 224main' :: IO () 225main' = do 226 -- Enable line buffering so that we can get fast feedback even when piped. 227 -- This is especially important for CI and build systems. 228 hSetBuffering stdout LineBuffering 229 -- If the locale encoding for CLI doesn't support all Unicode characters, 230 -- printing to it may fail unless we relax the handling of encoding errors 231 -- when writing to stderr and stdout. 232 relaxEncodingErrors stdout 233 relaxEncodingErrors stderr 234 (args0, args1) <- break (== "--") <$> getArgs 235 mainWorker =<< (++ args1) <$> expandResponse args0 236 237mainWorker :: [String] -> IO () 238mainWorker args = do 239 maybeScriptAndArgs <- case args of 240 [] -> return Nothing 241 (h:tl) -> (\b -> if b then Just (h:|tl) else Nothing) <$> CmdRun.validScript h 242 243 topHandler $ 244 case commandsRun (globalCommand commands) commands args of 245 CommandHelp help -> printGlobalHelp help 246 CommandList opts -> printOptionsList opts 247 CommandErrors errs -> printErrors errs 248 CommandReadyToGo (globalFlags, commandParse) -> 249 case commandParse of 250 _ | fromFlagOrDefault False (globalVersion globalFlags) 251 -> printVersion 252 | fromFlagOrDefault False (globalNumericVersion globalFlags) 253 -> printNumericVersion 254 CommandHelp help -> printCommandHelp help 255 CommandList opts -> printOptionsList opts 256 CommandErrors errs -> maybe (printErrors errs) go maybeScriptAndArgs where 257 go (script:|scriptArgs) = CmdRun.handleShebang script scriptArgs 258 CommandReadyToGo action -> do 259 globalFlags' <- updateSandboxConfigFileFlag globalFlags 260 action globalFlags' 261 262 where 263 printCommandHelp help = do 264 pname <- getProgName 265 putStr (help pname) 266 printGlobalHelp help = do 267 pname <- getProgName 268 configFile <- defaultConfigFile 269 putStr (help pname) 270 putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" 271 ++ " " ++ configFile ++ "\n" 272 exists <- doesFileExist configFile 273 unless exists $ 274 putStrLn $ "This file will be generated with sensible " 275 ++ "defaults if you run 'cabal update'." 276 printOptionsList = putStr . unlines 277 printErrors errs = dieNoVerbosity $ intercalate "\n" errs 278 printNumericVersion = putStrLn $ showVersion Paths_cabal_install.version 279 printVersion = putStrLn $ "cabal-install version " 280 ++ showVersion Paths_cabal_install.version 281 ++ "\ncompiled using version " 282 ++ display cabalVersion 283 ++ " of the Cabal library " 284 285 commands = map commandFromSpec commandSpecs 286 commandSpecs = 287 [ regularCmd listCommand listAction 288 , regularCmd infoCommand infoAction 289 , regularCmd fetchCommand fetchAction 290 , regularCmd getCommand getAction 291 , hiddenCmd unpackCommand unpackAction 292 , regularCmd checkCommand checkAction 293 , regularCmd uploadCommand uploadAction 294 , regularCmd reportCommand reportAction 295 , regularCmd initCommand initAction 296 , regularCmd userConfigCommand userConfigAction 297 , regularCmd genBoundsCommand genBoundsAction 298 , regularCmd outdatedCommand outdatedAction 299 , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref 300 , hiddenCmd uninstallCommand uninstallAction 301 , hiddenCmd formatCommand formatAction 302 , hiddenCmd upgradeCommand upgradeAction 303 , hiddenCmd win32SelfUpgradeCommand win32SelfUpgradeAction 304 , hiddenCmd actAsSetupCommand actAsSetupAction 305 , hiddenCmd manpageCommand (manpageAction commandSpecs) 306 307 ] ++ concat 308 [ newCmd CmdConfigure.configureCommand CmdConfigure.configureAction 309 , newCmd CmdUpdate.updateCommand CmdUpdate.updateAction 310 , newCmd CmdBuild.buildCommand CmdBuild.buildAction 311 , newCmd CmdRepl.replCommand CmdRepl.replAction 312 , newCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction 313 , newCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction 314 , newCmd CmdInstall.installCommand CmdInstall.installAction 315 , newCmd CmdRun.runCommand CmdRun.runAction 316 , newCmd CmdTest.testCommand CmdTest.testAction 317 , newCmd CmdBench.benchCommand CmdBench.benchAction 318 , newCmd CmdExec.execCommand CmdExec.execAction 319 , newCmd CmdClean.cleanCommand CmdClean.cleanAction 320 , newCmd CmdSdist.sdistCommand CmdSdist.sdistAction 321 322 , legacyCmd configureExCommand configureAction 323 , legacyCmd updateCommand updateAction 324 , legacyCmd buildCommand buildAction 325 , legacyCmd replCommand replAction 326 , legacyCmd freezeCommand freezeAction 327 , legacyCmd haddockCommand haddockAction 328 , legacyCmd installCommand installAction 329 , legacyCmd runCommand runAction 330 , legacyCmd testCommand testAction 331 , legacyCmd benchmarkCommand benchmarkAction 332 , legacyCmd execCommand execAction 333 , legacyCmd cleanCommand cleanAction 334 , legacyCmd sdistCommand sdistAction 335 , legacyCmd doctestCommand doctestAction 336 , legacyWrapperCmd copyCommand copyVerbosity copyDistPref 337 , legacyWrapperCmd registerCommand regVerbosity regDistPref 338 , legacyCmd reconfigureCommand reconfigureAction 339 , legacyCmd sandboxCommand sandboxAction 340 ] 341 342type Action = GlobalFlags -> IO () 343 344-- Duplicated in Distribution.Client.CmdLegacy. Any changes must be 345-- reflected there, as well. 346regularCmd :: CommandUI flags -> (flags -> [String] -> action) 347 -> CommandSpec action 348regularCmd ui action = 349 CommandSpec ui ((flip commandAddAction) action) NormalCommand 350 351hiddenCmd :: CommandUI flags -> (flags -> [String] -> action) 352 -> CommandSpec action 353hiddenCmd ui action = 354 CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action)) 355 HiddenCommand 356 357wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) 358 -> (flags -> Flag String) -> CommandSpec Action 359wrapperCmd ui verbosity distPref = 360 CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand 361 362wrapperAction :: Monoid flags 363 => CommandUI flags 364 -> (flags -> Flag Verbosity) 365 -> (flags -> Flag String) 366 -> Command Action 367wrapperAction command verbosityFlag distPrefFlag = 368 commandAddAction command 369 { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do 370 let verbosity = fromFlagOrDefault normal (verbosityFlag flags) 371 load <- try (loadConfigOrSandboxConfig verbosity globalFlags) 372 let config = either (\(SomeException _) -> mempty) snd load 373 distPref <- findSavedDistPref config (distPrefFlag flags) 374 let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } 375 setupWrapper verbosity setupScriptOptions Nothing 376 command (const flags) (const extraArgs) 377 378configureAction :: (ConfigFlags, ConfigExFlags) 379 -> [String] -> Action 380configureAction (configFlags, configExFlags) extraArgs globalFlags = do 381 let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) 382 (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) 383 <$> loadConfigOrSandboxConfig verbosity globalFlags 384 distPref <- findSavedDistPref config (configDistPref configFlags) 385 nixInstantiate verbosity distPref True globalFlags config 386 nixShell verbosity distPref globalFlags config $ do 387 let configFlags' = savedConfigureFlags config `mappend` configFlags 388 configExFlags' = savedConfigureExFlags config `mappend` configExFlags 389 globalFlags' = savedGlobalFlags config `mappend` globalFlags 390 (comp, platform, progdb) <- configCompilerAuxEx configFlags' 391 392 -- If we're working inside a sandbox and the user has set the -w option, we 393 -- may need to create a sandbox-local package DB for this compiler and add a 394 -- timestamp record for this compiler to the timestamp file. 395 let configFlags'' = case useSandbox of 396 NoSandbox -> configFlags' 397 (UseSandbox sandboxDir) -> setPackageDB sandboxDir 398 comp platform configFlags' 399 400 writeConfigFlags verbosity distPref (configFlags'', configExFlags') 401 402 -- What package database(s) to use 403 let packageDBs :: PackageDBStack 404 packageDBs 405 = interpretPackageDbFlags 406 (fromFlag (configUserInstall configFlags'')) 407 (configPackageDBs configFlags'') 408 409 whenUsingSandbox useSandbox $ \sandboxDir -> do 410 initPackageDBIfNeeded verbosity configFlags'' comp progdb 411 -- NOTE: We do not write the new sandbox package DB location to 412 -- 'cabal.sandbox.config' here because 'configure -w' must not affect 413 -- subsequent 'install' (for UI compatibility with non-sandboxed mode). 414 415 indexFile <- tryGetIndexFilePath verbosity config 416 maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile 417 (compilerId comp) platform 418 419 maybeWithSandboxDirOnSearchPath useSandbox $ 420 withRepoContext verbosity globalFlags' $ \repoContext -> 421 configure verbosity packageDBs repoContext 422 comp platform progdb configFlags'' configExFlags' extraArgs 423 424reconfigureAction :: (ConfigFlags, ConfigExFlags) 425 -> [String] -> Action 426reconfigureAction flags@(configFlags, _) _ globalFlags = do 427 let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) 428 (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) 429 <$> loadConfigOrSandboxConfig verbosity globalFlags 430 distPref <- findSavedDistPref config (configDistPref configFlags) 431 let checkFlags = Check $ \_ saved -> do 432 let flags' = saved <> flags 433 unless (saved == flags') $ info verbosity message 434 pure (Any True, flags') 435 where 436 -- This message is correct, but not very specific: it will list all 437 -- of the new flags, even if some have not actually changed. The 438 -- *minimal* set of changes is more difficult to determine. 439 message = 440 "flags changed: " 441 ++ unwords (commandShowOptions configureExCommand flags) 442 nixInstantiate verbosity distPref True globalFlags config 443 _ <- 444 reconfigure configureAction 445 verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag 446 checkFlags [] globalFlags config 447 pure () 448 449buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action 450buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do 451 let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) 452 noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck 453 (buildOnly buildExFlags) 454 (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags 455 distPref <- findSavedDistPref config (buildDistPref buildFlags) 456 -- Calls 'configureAction' to do the real work, so nothing special has to be 457 -- done to support sandboxes. 458 config' <- 459 reconfigure configureAction 460 verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags) 461 mempty [] globalFlags config 462 nixShell verbosity distPref globalFlags config $ do 463 maybeWithSandboxDirOnSearchPath useSandbox $ 464 build verbosity config' distPref buildFlags extraArgs 465 466 467-- | Actually do the work of building the package. This is separate from 468-- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke 469-- 'reconfigure' twice. 470build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO () 471build verbosity config distPref buildFlags extraArgs = 472 setupWrapper verbosity setupOptions Nothing 473 (Cabal.buildCommand progDb) mkBuildFlags (const extraArgs) 474 where 475 progDb = defaultProgramDb 476 setupOptions = defaultSetupScriptOptions { useDistPref = distPref } 477 478 mkBuildFlags version = filterBuildFlags version config buildFlags' 479 buildFlags' = buildFlags 480 { buildVerbosity = toFlag verbosity 481 , buildDistPref = toFlag distPref 482 } 483 484-- | Make sure that we don't pass new flags to setup scripts compiled against 485-- old versions of Cabal. 486filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags 487filterBuildFlags version config buildFlags 488 | version >= mkVersion [1,19,1] = buildFlags_latest 489 -- Cabal < 1.19.1 doesn't support 'build -j'. 490 | otherwise = buildFlags_pre_1_19_1 491 where 492 buildFlags_pre_1_19_1 = buildFlags { 493 buildNumJobs = NoFlag 494 } 495 buildFlags_latest = buildFlags { 496 -- Take the 'jobs' setting '~/.cabal/config' into account. 497 buildNumJobs = Flag . Just . determineNumJobs $ 498 (numJobsConfigFlag `mappend` numJobsCmdLineFlag) 499 } 500 numJobsConfigFlag = installNumJobs . savedInstallFlags $ config 501 numJobsCmdLineFlag = buildNumJobs buildFlags 502 503 504replAction :: (ReplFlags, BuildExFlags) -> [String] -> Action 505replAction (replFlags, buildExFlags) extraArgs globalFlags = do 506 let verbosity = fromFlagOrDefault normal (replVerbosity replFlags) 507 (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags 508 distPref <- findSavedDistPref config (replDistPref replFlags) 509 cwd <- getCurrentDirectory 510 pkgDesc <- findPackageDesc cwd 511 let 512 -- There is a .cabal file in the current directory: start a REPL and load 513 -- the project's modules. 514 onPkgDesc = do 515 let noAddSource = case replReload replFlags of 516 Flag True -> SkipAddSourceDepsCheck 517 _ -> fromFlagOrDefault DontSkipAddSourceDepsCheck 518 (buildOnly buildExFlags) 519 520 -- Calls 'configureAction' to do the real work, so nothing special has to 521 -- be done to support sandboxes. 522 _ <- 523 reconfigure configureAction 524 verbosity distPref useSandbox noAddSource NoFlag 525 mempty [] globalFlags config 526 let progDb = defaultProgramDb 527 setupOptions = defaultSetupScriptOptions 528 { useCabalVersion = orLaterVersion $ mkVersion [1,18,0] 529 , useDistPref = distPref 530 } 531 replFlags' = replFlags 532 { replVerbosity = toFlag verbosity 533 , replDistPref = toFlag distPref 534 } 535 536 nixShell verbosity distPref globalFlags config $ do 537 maybeWithSandboxDirOnSearchPath useSandbox $ 538 setupWrapper verbosity setupOptions Nothing 539 (Cabal.replCommand progDb) (const replFlags') (const extraArgs) 540 541 -- No .cabal file in the current directory: just start the REPL (possibly 542 -- using the sandbox package DB). 543 onNoPkgDesc = do 544 let configFlags = savedConfigureFlags config 545 (comp, platform, programDb) <- configCompilerAux' configFlags 546 programDb' <- reconfigurePrograms verbosity 547 (replProgramPaths replFlags) 548 (replProgramArgs replFlags) 549 programDb 550 nixShell verbosity distPref globalFlags config $ do 551 startInterpreter verbosity programDb' comp platform 552 (configPackageDB' configFlags) 553 554 either (const onNoPkgDesc) (const onPkgDesc) pkgDesc 555 556installAction :: ( ConfigFlags, ConfigExFlags, InstallFlags 557 , HaddockFlags, TestFlags, BenchmarkFlags ) 558 -> [String] -> Action 559installAction (configFlags, _, installFlags, _, _, _) _ globalFlags 560 | fromFlagOrDefault False (installOnly installFlags) = do 561 let verb = fromFlagOrDefault normal (configVerbosity configFlags) 562 (useSandbox, config) <- loadConfigOrSandboxConfig verb globalFlags 563 dist <- findSavedDistPref config (configDistPref configFlags) 564 let setupOpts = defaultSetupScriptOptions { useDistPref = dist } 565 nixShellIfSandboxed verb dist globalFlags config useSandbox $ 566 setupWrapper 567 verb setupOpts Nothing 568 installCommand (const (mempty, mempty, mempty, mempty, mempty, mempty)) 569 (const []) 570 571installAction 572 ( configFlags, configExFlags, installFlags 573 , haddockFlags, testFlags, benchmarkFlags ) 574 extraArgs globalFlags = do 575 let verb = fromFlagOrDefault normal (configVerbosity configFlags) 576 (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) 577 <$> loadConfigOrSandboxConfig verb globalFlags 578 579 let sandboxDist = 580 case useSandbox of 581 NoSandbox -> NoFlag 582 UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir 583 dist <- findSavedDistPref config 584 (configDistPref configFlags `mappend` sandboxDist) 585 586 nixShellIfSandboxed verb dist globalFlags config useSandbox $ do 587 targets <- readUserTargets verb extraArgs 588 589 -- TODO: It'd be nice if 'cabal install' picked up the '-w' flag passed to 590 -- 'configure' when run inside a sandbox. Right now, running 591 -- 592 -- \$ cabal sandbox init && cabal configure -w /path/to/ghc 593 -- && cabal build && cabal install 594 -- 595 -- performs the compilation twice unless you also pass -w to 'install'. 596 -- However, this is the same behaviour that 'cabal install' has in the normal 597 -- mode of operation, so we stick to it for consistency. 598 599 let configFlags' = maybeForceTests installFlags' $ 600 savedConfigureFlags config `mappend` 601 configFlags { configDistPref = toFlag dist } 602 configExFlags' = defaultConfigExFlags `mappend` 603 savedConfigureExFlags config `mappend` configExFlags 604 installFlags' = defaultInstallFlags `mappend` 605 savedInstallFlags config `mappend` installFlags 606 haddockFlags' = defaultHaddockFlags `mappend` 607 savedHaddockFlags config `mappend` 608 haddockFlags { haddockDistPref = toFlag dist } 609 testFlags' = Cabal.defaultTestFlags `mappend` 610 savedTestFlags config `mappend` 611 testFlags { testDistPref = toFlag dist } 612 benchmarkFlags' = Cabal.defaultBenchmarkFlags `mappend` 613 savedBenchmarkFlags config `mappend` 614 benchmarkFlags { benchmarkDistPref = toFlag dist } 615 globalFlags' = savedGlobalFlags config `mappend` globalFlags 616 (comp, platform, progdb) <- configCompilerAux' configFlags' 617 -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the 618 -- future. 619 progdb' <- configureAllKnownPrograms verb progdb 620 621 -- If we're working inside a sandbox and the user has set the -w option, we 622 -- may need to create a sandbox-local package DB for this compiler and add a 623 -- timestamp record for this compiler to the timestamp file. 624 configFlags'' <- case useSandbox of 625 NoSandbox -> configAbsolutePaths $ configFlags' 626 (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform 627 configFlags' 628 629 whenUsingSandbox useSandbox $ \sandboxDir -> do 630 initPackageDBIfNeeded verb configFlags'' comp progdb' 631 632 indexFile <- tryGetIndexFilePath verb config 633 maybeAddCompilerTimestampRecord verb sandboxDir indexFile 634 (compilerId comp) platform 635 636 -- TODO: Passing 'SandboxPackageInfo' to install unconditionally here means 637 -- that 'cabal install some-package' inside a sandbox will sometimes reinstall 638 -- modified add-source deps, even if they are not among the dependencies of 639 -- 'some-package'. This can also prevent packages that depend on older 640 -- versions of add-source'd packages from building (see #1362). 641 maybeWithSandboxPackageInfo verb configFlags'' globalFlags' 642 comp platform progdb useSandbox $ \mSandboxPkgInfo -> 643 maybeWithSandboxDirOnSearchPath useSandbox $ 644 withRepoContext verb globalFlags' $ \repoContext -> 645 install verb 646 (configPackageDB' configFlags'') 647 repoContext 648 comp platform progdb' 649 useSandbox mSandboxPkgInfo 650 globalFlags' configFlags'' configExFlags' 651 installFlags' haddockFlags' testFlags' benchmarkFlags' 652 targets 653 654 where 655 -- '--run-tests' implies '--enable-tests'. 656 maybeForceTests installFlags' configFlags' = 657 if fromFlagOrDefault False (installRunTests installFlags') 658 then configFlags' { configTests = toFlag True } 659 else configFlags' 660 661testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags 662 -> IO () 663testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do 664 let verbosity = fromFlagOrDefault normal (testVerbosity testFlags) 665 (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags 666 distPref <- findSavedDistPref config (testDistPref testFlags) 667 let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck 668 (buildOnly buildExFlags) 669 buildFlags' = buildFlags 670 { buildVerbosity = testVerbosity testFlags } 671 checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> 672 if fromFlagOrDefault False (configTests configFlags) 673 then pure (mempty, flags) 674 else do 675 info verbosity "reconfiguring to enable tests" 676 let flags' = ( configFlags { configTests = toFlag True } 677 , configExFlags 678 ) 679 pure (Any True, flags') 680 681 -- reconfigure also checks if we're in a sandbox and reinstalls add-source 682 -- deps if needed. 683 _ <- 684 reconfigure configureAction 685 verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags') 686 checkFlags [] globalFlags config 687 nixShell verbosity distPref globalFlags config $ do 688 let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } 689 testFlags' = testFlags { testDistPref = toFlag distPref } 690 691 -- The package was just configured, so the LBI must be available. 692 names <- componentNamesFromLBI verbosity distPref "test suites" 693 (\c -> case c of { LBI.CTest{} -> True; _ -> False }) 694 let extraArgs' 695 | null extraArgs = case names of 696 ComponentNamesUnknown -> [] 697 ComponentNames names' -> [ Make.unUnqualComponentName name 698 | LBI.CTestName name <- names' ] 699 | otherwise = extraArgs 700 701 maybeWithSandboxDirOnSearchPath useSandbox $ 702 build verbosity config distPref buildFlags' extraArgs' 703 704 maybeWithSandboxDirOnSearchPath useSandbox $ 705 setupWrapper verbosity setupOptions Nothing 706 Cabal.testCommand (const testFlags') (const extraArgs') 707 708data ComponentNames = ComponentNamesUnknown 709 | ComponentNames [LBI.ComponentName] 710 711-- | Return the names of all buildable components matching a given predicate. 712componentNamesFromLBI :: Verbosity -> FilePath -> String 713 -> (LBI.Component -> Bool) 714 -> IO ComponentNames 715componentNamesFromLBI verbosity distPref targetsDescr compPred = do 716 eLBI <- tryGetPersistBuildConfig distPref 717 case eLBI of 718 Left err -> case err of 719 -- Note: the build config could have been generated by a custom setup 720 -- script built against a different Cabal version, so it's crucial that 721 -- we ignore the bad version error here. 722 ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown 723 _ -> die' verbosity (show err) 724 Right lbi -> do 725 let pkgDescr = LBI.localPkgDescr lbi 726 names = map LBI.componentName 727 . filter (buildable . LBI.componentBuildInfo) 728 . filter compPred $ 729 LBI.pkgComponents pkgDescr 730 if null names 731 then do notice verbosity $ "Package has no buildable " 732 ++ targetsDescr ++ "." 733 exitSuccess -- See #3215. 734 735 else return $! (ComponentNames names) 736 737benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags) 738 -> [String] -> GlobalFlags 739 -> IO () 740benchmarkAction 741 (benchmarkFlags, buildFlags, buildExFlags) 742 extraArgs globalFlags = do 743 let verbosity = fromFlagOrDefault normal 744 (benchmarkVerbosity benchmarkFlags) 745 746 (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags 747 distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags) 748 let buildFlags' = buildFlags 749 { buildVerbosity = benchmarkVerbosity benchmarkFlags } 750 noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck 751 (buildOnly buildExFlags) 752 753 let checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> 754 if fromFlagOrDefault False (configBenchmarks configFlags) 755 then pure (mempty, flags) 756 else do 757 info verbosity "reconfiguring to enable benchmarks" 758 let flags' = ( configFlags { configBenchmarks = toFlag True } 759 , configExFlags 760 ) 761 pure (Any True, flags') 762 763 764 -- reconfigure also checks if we're in a sandbox and reinstalls add-source 765 -- deps if needed. 766 config' <- 767 reconfigure configureAction 768 verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags') 769 checkFlags [] globalFlags config 770 nixShell verbosity distPref globalFlags config $ do 771 let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } 772 benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref } 773 774 -- The package was just configured, so the LBI must be available. 775 names <- componentNamesFromLBI verbosity distPref "benchmarks" 776 (\c -> case c of { LBI.CBench{} -> True; _ -> False; }) 777 let extraArgs' 778 | null extraArgs = case names of 779 ComponentNamesUnknown -> [] 780 ComponentNames names' -> [ Make.unUnqualComponentName name 781 | LBI.CBenchName name <- names'] 782 | otherwise = extraArgs 783 784 maybeWithSandboxDirOnSearchPath useSandbox $ 785 build verbosity config' distPref buildFlags' extraArgs' 786 787 maybeWithSandboxDirOnSearchPath useSandbox $ 788 setupWrapper verbosity setupOptions Nothing 789 Cabal.benchmarkCommand (const benchmarkFlags') (const extraArgs') 790 791haddockAction :: HaddockFlags -> [String] -> Action 792haddockAction haddockFlags extraArgs globalFlags = do 793 let verbosity = fromFlag (haddockVerbosity haddockFlags) 794 (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags 795 distPref <- findSavedDistPref config (haddockDistPref haddockFlags) 796 config' <- 797 reconfigure configureAction 798 verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag 799 mempty [] globalFlags config 800 nixShell verbosity distPref globalFlags config $ do 801 let haddockFlags' = defaultHaddockFlags `mappend` 802 savedHaddockFlags config' `mappend` 803 haddockFlags { haddockDistPref = toFlag distPref } 804 setupScriptOptions = defaultSetupScriptOptions 805 { useDistPref = distPref } 806 setupWrapper verbosity setupScriptOptions Nothing 807 haddockCommand (const haddockFlags') (const extraArgs) 808 when (haddockForHackage haddockFlags == Flag ForHackage) $ do 809 pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) 810 let dest = distPref </> name <.> "tar.gz" 811 name = display (packageId pkg) ++ "-docs" 812 docDir = distPref </> "doc" </> "html" 813 createTarGzFile dest docDir name 814 notice verbosity $ "Documentation tarball created: " ++ dest 815 816doctestAction :: DoctestFlags -> [String] -> Action 817doctestAction doctestFlags extraArgs _globalFlags = do 818 let verbosity = fromFlag (doctestVerbosity doctestFlags) 819 820 setupWrapper verbosity defaultSetupScriptOptions Nothing 821 doctestCommand (const doctestFlags) (const extraArgs) 822 823cleanAction :: CleanFlags -> [String] -> Action 824cleanAction cleanFlags extraArgs globalFlags = do 825 load <- try (loadConfigOrSandboxConfig verbosity globalFlags) 826 let config = either (\(SomeException _) -> mempty) snd load 827 distPref <- findSavedDistPref config (cleanDistPref cleanFlags) 828 let setupScriptOptions = defaultSetupScriptOptions 829 { useDistPref = distPref 830 , useWin32CleanHack = True 831 } 832 cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref } 833 setupWrapper verbosity setupScriptOptions Nothing 834 cleanCommand (const cleanFlags') (const extraArgs) 835 where 836 verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags) 837 838listAction :: ListFlags -> [String] -> Action 839listAction listFlags extraArgs globalFlags = do 840 let verbosity = fromFlag (listVerbosity listFlags) 841 (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity 842 (globalFlags { globalRequireSandbox = Flag False }) 843 let configFlags' = savedConfigureFlags config 844 configFlags = configFlags' { 845 configPackageDBs = configPackageDBs configFlags' 846 `mappend` listPackageDBs listFlags 847 } 848 globalFlags' = savedGlobalFlags config `mappend` globalFlags 849 (comp, _, progdb) <- configCompilerAux' configFlags 850 withRepoContext verbosity globalFlags' $ \repoContext -> 851 List.list verbosity 852 (configPackageDB' configFlags) 853 repoContext 854 comp 855 progdb 856 listFlags 857 extraArgs 858 859infoAction :: InfoFlags -> [String] -> Action 860infoAction infoFlags extraArgs globalFlags = do 861 let verbosity = fromFlag (infoVerbosity infoFlags) 862 targets <- readUserTargets verbosity extraArgs 863 (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity 864 (globalFlags { globalRequireSandbox = Flag False }) 865 let configFlags' = savedConfigureFlags config 866 configFlags = configFlags' { 867 configPackageDBs = configPackageDBs configFlags' 868 `mappend` infoPackageDBs infoFlags 869 } 870 globalFlags' = savedGlobalFlags config `mappend` globalFlags 871 (comp, _, progdb) <- configCompilerAuxEx configFlags 872 withRepoContext verbosity globalFlags' $ \repoContext -> 873 List.info verbosity 874 (configPackageDB' configFlags) 875 repoContext 876 comp 877 progdb 878 globalFlags' 879 infoFlags 880 targets 881 882updateAction :: UpdateFlags -> [String] -> Action 883updateAction updateFlags extraArgs globalFlags = do 884 let verbosity = fromFlag (updateVerbosity updateFlags) 885 unless (null extraArgs) $ 886 die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs 887 (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity 888 (globalFlags { globalRequireSandbox = Flag False }) 889 let globalFlags' = savedGlobalFlags config `mappend` globalFlags 890 withRepoContext verbosity globalFlags' $ \repoContext -> 891 update verbosity updateFlags repoContext 892 893upgradeAction :: ( ConfigFlags, ConfigExFlags, InstallFlags 894 , HaddockFlags, TestFlags, BenchmarkFlags ) 895 -> [String] -> Action 896upgradeAction (configFlags, _, _, _, _, _) _ _ = die' verbosity $ 897 "Use the 'cabal install' command instead of 'cabal upgrade'.\n" 898 ++ "You can install the latest version of a package using 'cabal install'. " 899 ++ "The 'cabal upgrade' command has been removed because people found it " 900 ++ "confusing and it often led to broken packages.\n" 901 ++ "If you want the old upgrade behaviour then use the install command " 902 ++ "with the --upgrade-dependencies flag (but check first with --dry-run " 903 ++ "to see what would happen). This will try to pick the latest versions " 904 ++ "of all dependencies, rather than the usual behaviour of trying to pick " 905 ++ "installed versions of all dependencies. If you do use " 906 ++ "--upgrade-dependencies, it is recommended that you do not upgrade core " 907 ++ "packages (e.g. by using appropriate --constraint= flags)." 908 where 909 verbosity = fromFlag (configVerbosity configFlags) 910 911fetchAction :: FetchFlags -> [String] -> Action 912fetchAction fetchFlags extraArgs globalFlags = do 913 let verbosity = fromFlag (fetchVerbosity fetchFlags) 914 targets <- readUserTargets verbosity extraArgs 915 config <- loadConfig verbosity (globalConfigFile globalFlags) 916 let configFlags = savedConfigureFlags config 917 globalFlags' = savedGlobalFlags config `mappend` globalFlags 918 (comp, platform, progdb) <- configCompilerAux' configFlags 919 withRepoContext verbosity globalFlags' $ \repoContext -> 920 fetch verbosity 921 (configPackageDB' configFlags) 922 repoContext 923 comp platform progdb globalFlags' fetchFlags 924 targets 925 926freezeAction :: FreezeFlags -> [String] -> Action 927freezeAction freezeFlags _extraArgs globalFlags = do 928 let verbosity = fromFlag (freezeVerbosity freezeFlags) 929 (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags 930 distPref <- findSavedDistPref config NoFlag 931 nixShell verbosity distPref globalFlags config $ do 932 let configFlags = savedConfigureFlags config 933 globalFlags' = savedGlobalFlags config `mappend` globalFlags 934 (comp, platform, progdb) <- configCompilerAux' configFlags 935 936 maybeWithSandboxPackageInfo 937 verbosity configFlags globalFlags' 938 comp platform progdb useSandbox $ \mSandboxPkgInfo -> 939 maybeWithSandboxDirOnSearchPath useSandbox $ 940 withRepoContext verbosity globalFlags' $ \repoContext -> 941 freeze verbosity 942 (configPackageDB' configFlags) 943 repoContext 944 comp platform progdb 945 mSandboxPkgInfo 946 globalFlags' freezeFlags 947 948genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () 949genBoundsAction freezeFlags _extraArgs globalFlags = do 950 let verbosity = fromFlag (freezeVerbosity freezeFlags) 951 (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags 952 distPref <- findSavedDistPref config NoFlag 953 nixShell verbosity distPref globalFlags config $ do 954 let configFlags = savedConfigureFlags config 955 globalFlags' = savedGlobalFlags config `mappend` globalFlags 956 (comp, platform, progdb) <- configCompilerAux' configFlags 957 958 maybeWithSandboxPackageInfo 959 verbosity configFlags globalFlags' 960 comp platform progdb useSandbox $ \mSandboxPkgInfo -> 961 maybeWithSandboxDirOnSearchPath useSandbox $ 962 withRepoContext verbosity globalFlags' $ \repoContext -> 963 genBounds verbosity 964 (configPackageDB' configFlags) 965 repoContext 966 comp platform progdb 967 mSandboxPkgInfo 968 globalFlags' freezeFlags 969 970outdatedAction :: OutdatedFlags -> [String] -> GlobalFlags -> IO () 971outdatedAction outdatedFlags _extraArgs globalFlags = do 972 let verbosity = fromFlag (outdatedVerbosity outdatedFlags) 973 (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags 974 let configFlags = savedConfigureFlags config 975 globalFlags' = savedGlobalFlags config `mappend` globalFlags 976 (comp, platform, _progdb) <- configCompilerAux' configFlags 977 withRepoContext verbosity globalFlags' $ \repoContext -> 978 outdated verbosity outdatedFlags repoContext 979 comp platform 980 981uploadAction :: UploadFlags -> [String] -> Action 982uploadAction uploadFlags extraArgs globalFlags = do 983 config <- loadConfig verbosity (globalConfigFile globalFlags) 984 let uploadFlags' = savedUploadFlags config `mappend` uploadFlags 985 globalFlags' = savedGlobalFlags config `mappend` globalFlags 986 tarfiles = extraArgs 987 when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $ 988 die' verbosity "the 'upload' command expects at least one .tar.gz archive." 989 checkTarFiles extraArgs 990 maybe_password <- 991 case uploadPasswordCmd uploadFlags' 992 of Flag (xs:xss) -> Just . Password <$> 993 getProgramInvocationOutput verbosity 994 (simpleProgramInvocation xs xss) 995 _ -> pure $ flagToMaybe $ uploadPassword uploadFlags' 996 withRepoContext verbosity globalFlags' $ \repoContext -> do 997 if fromFlag (uploadDoc uploadFlags') 998 then do 999 when (length tarfiles > 1) $ 1000 die' verbosity $ "the 'upload' command can only upload documentation " 1001 ++ "for one package at a time." 1002 tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles 1003 Upload.uploadDoc verbosity 1004 repoContext 1005 (flagToMaybe $ uploadUsername uploadFlags') 1006 maybe_password 1007 (fromFlag (uploadCandidate uploadFlags')) 1008 tarfile 1009 else do 1010 Upload.upload verbosity 1011 repoContext 1012 (flagToMaybe $ uploadUsername uploadFlags') 1013 maybe_password 1014 (fromFlag (uploadCandidate uploadFlags')) 1015 tarfiles 1016 where 1017 verbosity = fromFlag (uploadVerbosity uploadFlags) 1018 checkTarFiles tarfiles 1019 | not (null otherFiles) 1020 = die' verbosity $ "the 'upload' command expects only .tar.gz archives: " 1021 ++ intercalate ", " otherFiles 1022 | otherwise = sequence_ 1023 [ do exists <- doesFileExist tarfile 1024 unless exists $ die' verbosity $ "file not found: " ++ tarfile 1025 | tarfile <- tarfiles ] 1026 1027 where otherFiles = filter (not . isTarGzFile) tarfiles 1028 isTarGzFile file = case splitExtension file of 1029 (file', ".gz") -> takeExtension file' == ".tar" 1030 _ -> False 1031 generateDocTarball config = do 1032 notice verbosity $ 1033 "No documentation tarball specified. " 1034 ++ "Building a documentation tarball with default settings...\n" 1035 ++ "If you need to customise Haddock options, " 1036 ++ "run 'haddock --for-hackage' first " 1037 ++ "to generate a documentation tarball." 1038 haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage }) 1039 [] globalFlags 1040 distPref <- findSavedDistPref config NoFlag 1041 pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) 1042 return $ distPref </> display (packageId pkg) ++ "-docs" <.> "tar.gz" 1043 1044checkAction :: Flag Verbosity -> [String] -> Action 1045checkAction verbosityFlag extraArgs _globalFlags = do 1046 let verbosity = fromFlag verbosityFlag 1047 unless (null extraArgs) $ 1048 die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs 1049 allOk <- Check.check (fromFlag verbosityFlag) 1050 unless allOk exitFailure 1051 1052formatAction :: Flag Verbosity -> [String] -> Action 1053formatAction verbosityFlag extraArgs _globalFlags = do 1054 let verbosity = fromFlag verbosityFlag 1055 path <- case extraArgs of 1056 [] -> do cwd <- getCurrentDirectory 1057 tryFindPackageDesc verbosity cwd 1058 (p:_) -> return p 1059 pkgDesc <- readGenericPackageDescription verbosity path 1060 -- Uses 'writeFileAtomic' under the hood. 1061 writeGenericPackageDescription path pkgDesc 1062 1063uninstallAction :: Flag Verbosity -> [String] -> Action 1064uninstallAction verbosityFlag extraArgs _globalFlags = do 1065 let verbosity = fromFlag verbosityFlag 1066 package = case extraArgs of 1067 p:_ -> p 1068 _ -> "PACKAGE_NAME" 1069 die' verbosity $ "This version of 'cabal-install' does not support the 'uninstall' " 1070 ++ "operation. " 1071 ++ "It will likely be implemented at some point in the future; " 1072 ++ "in the meantime you're advised to use either 'ghc-pkg unregister " 1073 ++ package ++ "' or 'cabal sandbox hc-pkg -- unregister " ++ package ++ "'." 1074 1075 1076sdistAction :: SDistFlags -> [String] -> Action 1077sdistAction sdistFlags extraArgs globalFlags = do 1078 let verbosity = fromFlag (sDistVerbosity sdistFlags) 1079 unless (null extraArgs) $ 1080 die' verbosity $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs 1081 load <- try (loadConfigOrSandboxConfig verbosity globalFlags) 1082 let config = either (\(SomeException _) -> mempty) snd load 1083 distPref <- findSavedDistPref config (sDistDistPref sdistFlags) 1084 sdist sdistFlags { sDistDistPref = toFlag distPref } 1085 1086reportAction :: ReportFlags -> [String] -> Action 1087reportAction reportFlags extraArgs globalFlags = do 1088 let verbosity = fromFlag (reportVerbosity reportFlags) 1089 unless (null extraArgs) $ 1090 die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs 1091 config <- loadConfig verbosity (globalConfigFile globalFlags) 1092 let globalFlags' = savedGlobalFlags config `mappend` globalFlags 1093 reportFlags' = savedReportFlags config `mappend` reportFlags 1094 1095 withRepoContext verbosity globalFlags' $ \repoContext -> 1096 Upload.report verbosity repoContext 1097 (flagToMaybe $ reportUsername reportFlags') 1098 (flagToMaybe $ reportPassword reportFlags') 1099 1100runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action 1101runAction (buildFlags, buildExFlags) extraArgs globalFlags = do 1102 let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) 1103 (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags 1104 distPref <- findSavedDistPref config (buildDistPref buildFlags) 1105 let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck 1106 (buildOnly buildExFlags) 1107 -- reconfigure also checks if we're in a sandbox and reinstalls add-source 1108 -- deps if needed. 1109 config' <- 1110 reconfigure configureAction 1111 verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags) 1112 mempty [] globalFlags config 1113 nixShell verbosity distPref globalFlags config $ do 1114 lbi <- getPersistBuildConfig distPref 1115 (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs 1116 1117 maybeWithSandboxDirOnSearchPath useSandbox $ 1118 build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)] 1119 1120 maybeWithSandboxDirOnSearchPath useSandbox $ 1121 run verbosity lbi exe exeArgs 1122 1123getAction :: GetFlags -> [String] -> Action 1124getAction getFlags extraArgs globalFlags = do 1125 let verbosity = fromFlag (getVerbosity getFlags) 1126 targets <- readUserTargets verbosity extraArgs 1127 (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity 1128 (globalFlags { globalRequireSandbox = Flag False }) 1129 let globalFlags' = savedGlobalFlags config `mappend` globalFlags 1130 withRepoContext verbosity (savedGlobalFlags config) $ \repoContext -> 1131 get verbosity 1132 repoContext 1133 globalFlags' 1134 getFlags 1135 targets 1136 1137unpackAction :: GetFlags -> [String] -> Action 1138unpackAction getFlags extraArgs globalFlags = do 1139 getAction getFlags extraArgs globalFlags 1140 1141initAction :: InitFlags -> [String] -> Action 1142initAction initFlags extraArgs globalFlags = do 1143 let verbosity = fromFlag (initVerbosity initFlags) 1144 when (extraArgs /= []) $ 1145 die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs 1146 (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity 1147 (globalFlags { globalRequireSandbox = Flag False }) 1148 let configFlags = savedConfigureFlags config `mappend` 1149 -- override with `--with-compiler` from CLI if available 1150 mempty { configHcPath = initHcPath initFlags } 1151 let initFlags' = savedInitFlags config `mappend` initFlags 1152 let globalFlags' = savedGlobalFlags config `mappend` globalFlags 1153 (comp, _, progdb) <- configCompilerAux' configFlags 1154 withRepoContext verbosity globalFlags' $ \repoContext -> 1155 initCabal verbosity 1156 (configPackageDB' configFlags) 1157 repoContext 1158 comp 1159 progdb 1160 initFlags' 1161 1162sandboxAction :: SandboxFlags -> [String] -> Action 1163sandboxAction sandboxFlags extraArgs globalFlags = do 1164 let verbosity = fromFlag (sandboxVerbosity sandboxFlags) 1165 case extraArgs of 1166 -- Basic sandbox commands. 1167 ["init"] -> sandboxInit verbosity sandboxFlags globalFlags 1168 ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags 1169 ("add-source":extra) -> do 1170 when (noExtraArgs extra) $ 1171 die' verbosity "The 'sandbox add-source' command expects at least one argument" 1172 sandboxAddSource verbosity extra sandboxFlags globalFlags 1173 ("delete-source":extra) -> do 1174 when (noExtraArgs extra) $ 1175 die' verbosity ("The 'sandbox delete-source' command expects " ++ 1176 "at least one argument") 1177 sandboxDeleteSource verbosity extra sandboxFlags globalFlags 1178 ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags 1179 1180 -- More advanced commands. 1181 ("hc-pkg":extra) -> do 1182 when (noExtraArgs extra) $ 1183 die' verbosity $ "The 'sandbox hc-pkg' command expects at least one argument" 1184 sandboxHcPkg verbosity sandboxFlags globalFlags extra 1185 ["buildopts"] -> die' verbosity "Not implemented!" 1186 1187 -- Hidden commands. 1188 ["dump-pkgenv"] -> dumpPackageEnvironment verbosity sandboxFlags globalFlags 1189 1190 -- Error handling. 1191 [] -> die' verbosity $ "Please specify a subcommand (see 'help sandbox')" 1192 _ -> die' verbosity $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs 1193 1194 where 1195 noExtraArgs = (<1) . length 1196 1197execAction :: ExecFlags -> [String] -> Action 1198execAction execFlags extraArgs globalFlags = do 1199 let verbosity = fromFlag (execVerbosity execFlags) 1200 (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags 1201 distPref <- findSavedDistPref config (execDistPref execFlags) 1202 let configFlags = savedConfigureFlags config 1203 configFlags' = configFlags { configDistPref = Flag distPref } 1204 (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags' 1205 exec verbosity useSandbox comp platform progdb extraArgs 1206 1207userConfigAction :: UserConfigFlags -> [String] -> Action 1208userConfigAction ucflags extraArgs globalFlags = do 1209 let verbosity = fromFlag (userConfigVerbosity ucflags) 1210 force = fromFlag (userConfigForce ucflags) 1211 extraLines = fromFlag (userConfigAppendLines ucflags) 1212 case extraArgs of 1213 ("init":_) -> do 1214 path <- configFile 1215 fileExists <- doesFileExist path 1216 if (not fileExists || (fileExists && force)) 1217 then void $ createDefaultConfigFile verbosity extraLines path 1218 else die' verbosity $ path ++ " already exists." 1219 ("diff":_) -> mapM_ putStrLn =<< userConfigDiff verbosity globalFlags extraLines 1220 ("update":_) -> userConfigUpdate verbosity globalFlags extraLines 1221 -- Error handling. 1222 [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')" 1223 _ -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs 1224 where configFile = getConfigFilePath (globalConfigFile globalFlags) 1225 1226-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. 1227-- 1228win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action 1229win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do 1230 let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags) 1231 Win32SelfUpgrade.deleteOldExeFile verbosity (fromMaybe (error $ "panic! read pid=" ++ show pid) $ readMaybe pid) path -- TODO: eradicateNoParse 1232win32SelfUpgradeAction _ _ _ = return () 1233 1234-- | Used as an entry point when cabal-install needs to invoke itself 1235-- as a setup script. This can happen e.g. when doing parallel builds. 1236-- 1237actAsSetupAction :: ActAsSetupFlags -> [String] -> Action 1238actAsSetupAction actAsSetupFlags args _globalFlags = 1239 let bt = fromFlag (actAsSetupBuildType actAsSetupFlags) 1240 in case bt of 1241 Simple -> Simple.defaultMainArgs args 1242 Configure -> Simple.defaultMainWithHooksArgs 1243 Simple.autoconfUserHooks args 1244 Make -> Make.defaultMainArgs args 1245 Custom -> error "actAsSetupAction Custom" 1246 1247manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action 1248manpageAction commands flagVerbosity extraArgs _ = do 1249 let verbosity = fromFlag flagVerbosity 1250 unless (null extraArgs) $ 1251 die' verbosity $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs 1252 pname <- getProgName 1253 let cabalCmd = if takeExtension pname == ".exe" 1254 then dropExtension pname 1255 else pname 1256 putStrLn $ manpage cabalCmd commands 1257