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(..) 25 , buildCommand, replCommand, testCommand, benchmarkCommand 26 , InstallFlags(..), defaultInstallFlags 27 , installCommand 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, listNeedsCompiler 37 , InfoFlags(..), infoCommand 38 , UploadFlags(..), uploadCommand 39 , ReportFlags(..), reportCommand 40 , runCommand 41 , InitFlags(initVerbosity, initHcPath), initCommand 42 , ActAsSetupFlags(..), actAsSetupCommand 43 , ExecFlags(..), execCommand 44 , UserConfigFlags(..), userConfigCommand 45 , reportCommand 46 , manpageCommand 47 , haddockCommand 48 , cleanCommand 49 , doctestCommand 50 , copyCommand 51 , registerCommand 52 ) 53import Distribution.Simple.Setup 54 ( HaddockTarget(..) 55 , DoctestFlags(..) 56 , HaddockFlags(..), defaultHaddockFlags 57 , HscolourFlags(..), hscolourCommand 58 , ReplFlags(..) 59 , CopyFlags(..) 60 , RegisterFlags(..) 61 , CleanFlags(..) 62 , TestFlags(..), BenchmarkFlags(..) 63 , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag 64 , configAbsolutePaths 65 ) 66 67import Prelude () 68import Distribution.Solver.Compat.Prelude hiding (get) 69 70import Distribution.Client.SetupWrapper 71 ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) 72import Distribution.Client.Config 73 ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff 74 , userConfigUpdate, createDefaultConfigFile, getConfigFilePath ) 75import Distribution.Client.Targets 76 ( readUserTargets ) 77import qualified Distribution.Client.List as List 78 ( list, info ) 79 80import qualified Distribution.Client.CmdConfigure as CmdConfigure 81import qualified Distribution.Client.CmdUpdate as CmdUpdate 82import qualified Distribution.Client.CmdBuild as CmdBuild 83import qualified Distribution.Client.CmdRepl as CmdRepl 84import qualified Distribution.Client.CmdFreeze as CmdFreeze 85import qualified Distribution.Client.CmdHaddock as CmdHaddock 86import qualified Distribution.Client.CmdInstall as CmdInstall 87import qualified Distribution.Client.CmdRun as CmdRun 88import qualified Distribution.Client.CmdTest as CmdTest 89import qualified Distribution.Client.CmdBench as CmdBench 90import qualified Distribution.Client.CmdExec as CmdExec 91import qualified Distribution.Client.CmdClean as CmdClean 92import qualified Distribution.Client.CmdSdist as CmdSdist 93import qualified Distribution.Client.CmdListBin as CmdListBin 94import Distribution.Client.CmdLegacy 95 96import Distribution.Client.Install (install) 97import Distribution.Client.Configure (configure, writeConfigFlags) 98import Distribution.Client.Update (update) 99import Distribution.Client.Exec (exec) 100import Distribution.Client.Fetch (fetch) 101import Distribution.Client.Freeze (freeze) 102import Distribution.Client.GenBounds (genBounds) 103import Distribution.Client.Outdated (outdated) 104import Distribution.Client.Check as Check (check) 105--import Distribution.Client.Clean (clean) 106import qualified Distribution.Client.Upload as Upload 107import Distribution.Client.Run (run, splitRunArgs) 108import Distribution.Client.Get (get) 109import Distribution.Client.Reconfigure (Check(..), reconfigure) 110import Distribution.Client.Nix (nixInstantiate 111 ,nixShell 112 ) 113import Distribution.Client.Sandbox (loadConfigOrSandboxConfig 114 ,findSavedDistPref 115 ,updateInstallDirs 116 ,getPersistOrConfigCompiler) 117import Distribution.Client.Tar (createTarGzFile) 118import Distribution.Client.Types.Credentials (Password (..)) 119import Distribution.Client.Init (initCabal) 120import Distribution.Client.Manpage (manpageCmd) 121import Distribution.Client.ManpageFlags (ManpageFlags (..)) 122import Distribution.Client.Utils (determineNumJobs 123 ,relaxEncodingErrors 124 ) 125 126import Distribution.Package (packageId) 127import Distribution.PackageDescription 128 ( BuildType(..), Executable(..), buildable ) 129import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) 130 131import Distribution.PackageDescription.PrettyPrint 132 ( writeGenericPackageDescription ) 133import qualified Distribution.Simple as Simple 134import qualified Distribution.Make as Make 135import qualified Distribution.Types.UnqualComponentName as Make 136import Distribution.Simple.Build 137 ( startInterpreter ) 138import Distribution.Simple.Command 139 ( CommandParse(..), CommandUI(..), Command, CommandSpec(..) 140 , CommandType(..), commandsRun, commandAddAction, hiddenCommand 141 , commandFromSpec, commandShowOptions ) 142import Distribution.Simple.Compiler (PackageDBStack) 143import Distribution.Simple.Configure 144 ( configCompilerAuxEx, ConfigStateFileError(..) 145 , getPersistBuildConfig, interpretPackageDbFlags 146 , tryGetPersistBuildConfig ) 147import qualified Distribution.Simple.LocalBuildInfo as LBI 148import Distribution.Simple.Program (defaultProgramDb 149 ,configureAllKnownPrograms 150 ,simpleProgramInvocation 151 ,getProgramInvocationOutput) 152import Distribution.Simple.Program.Db (reconfigurePrograms) 153import qualified Distribution.Simple.Setup as Cabal 154import Distribution.Simple.Utils 155 ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler 156 , findPackageDesc, tryFindPackageDesc ) 157import Distribution.Text 158 ( display ) 159import Distribution.Verbosity as Verbosity 160 ( Verbosity, normal ) 161import Distribution.Version 162 ( Version, mkVersion, orLaterVersion ) 163import qualified Paths_cabal_install (version) 164 165import Distribution.Compat.ResponseFile 166import System.Environment (getArgs, getProgName) 167import System.FilePath ( dropExtension, splitExtension 168 , takeExtension, (</>), (<.>) ) 169import System.IO ( BufferMode(LineBuffering), hSetBuffering 170 , stderr, stdout ) 171import System.Directory (doesFileExist, getCurrentDirectory) 172import Data.Monoid (Any(..)) 173import Control.Exception (try) 174import Data.Version (showVersion) 175 176-- | Entry point 177-- 178main :: IO () 179main = do 180 -- Enable line buffering so that we can get fast feedback even when piped. 181 -- This is especially important for CI and build systems. 182 hSetBuffering stdout LineBuffering 183 -- If the locale encoding for CLI doesn't support all Unicode characters, 184 -- printing to it may fail unless we relax the handling of encoding errors 185 -- when writing to stderr and stdout. 186 relaxEncodingErrors stdout 187 relaxEncodingErrors stderr 188 (args0, args1) <- break (== "--") <$> getArgs 189 mainWorker =<< (++ args1) <$> expandResponse args0 190 191mainWorker :: [String] -> IO () 192mainWorker args = do 193 maybeScriptAndArgs <- case args of 194 [] -> return Nothing 195 (h:tl) -> (\b -> if b then Just (h:|tl) else Nothing) <$> CmdRun.validScript h 196 197 topHandler $ 198 case commandsRun (globalCommand commands) commands args of 199 CommandHelp help -> printGlobalHelp help 200 CommandList opts -> printOptionsList opts 201 CommandErrors errs -> printErrors errs 202 CommandReadyToGo (globalFlags, commandParse) -> 203 case commandParse of 204 _ | fromFlagOrDefault False (globalVersion globalFlags) 205 -> printVersion 206 | fromFlagOrDefault False (globalNumericVersion globalFlags) 207 -> printNumericVersion 208 CommandHelp help -> printCommandHelp help 209 CommandList opts -> printOptionsList opts 210 CommandErrors errs -> maybe (printErrors errs) go maybeScriptAndArgs where 211 go (script:|scriptArgs) = CmdRun.handleShebang script scriptArgs 212 CommandReadyToGo action -> action globalFlags 213 214 where 215 printCommandHelp help = do 216 pname <- getProgName 217 putStr (help pname) 218 printGlobalHelp help = do 219 pname <- getProgName 220 configFile <- defaultConfigFile 221 putStr (help pname) 222 putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" 223 ++ " " ++ configFile ++ "\n" 224 exists <- doesFileExist configFile 225 unless exists $ 226 putStrLn $ "This file will be generated with sensible " 227 ++ "defaults if you run 'cabal update'." 228 printOptionsList = putStr . unlines 229 printErrors errs = dieNoVerbosity $ intercalate "\n" errs 230 printNumericVersion = putStrLn $ showVersion Paths_cabal_install.version 231 printVersion = putStrLn $ "cabal-install version " 232 ++ showVersion Paths_cabal_install.version 233 ++ "\ncompiled using version " 234 ++ display cabalVersion 235 ++ " of the Cabal library " 236 237 commands = map commandFromSpec commandSpecs 238 commandSpecs = 239 [ regularCmd listCommand listAction 240 , regularCmd infoCommand infoAction 241 , regularCmd fetchCommand fetchAction 242 , regularCmd getCommand getAction 243 , hiddenCmd unpackCommand unpackAction 244 , regularCmd checkCommand checkAction 245 , regularCmd uploadCommand uploadAction 246 , regularCmd reportCommand reportAction 247 , regularCmd initCommand initAction 248 , regularCmd userConfigCommand userConfigAction 249 , regularCmd genBoundsCommand genBoundsAction 250 , regularCmd outdatedCommand outdatedAction 251 , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref 252 , hiddenCmd formatCommand formatAction 253 , hiddenCmd actAsSetupCommand actAsSetupAction 254 , hiddenCmd manpageCommand (manpageAction commandSpecs) 255 , regularCmd CmdListBin.listbinCommand CmdListBin.listbinAction 256 257 ] ++ concat 258 [ newCmd CmdConfigure.configureCommand CmdConfigure.configureAction 259 , newCmd CmdUpdate.updateCommand CmdUpdate.updateAction 260 , newCmd CmdBuild.buildCommand CmdBuild.buildAction 261 , newCmd CmdRepl.replCommand CmdRepl.replAction 262 , newCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction 263 , newCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction 264 , newCmd CmdInstall.installCommand CmdInstall.installAction 265 , newCmd CmdRun.runCommand CmdRun.runAction 266 , newCmd CmdTest.testCommand CmdTest.testAction 267 , newCmd CmdBench.benchCommand CmdBench.benchAction 268 , newCmd CmdExec.execCommand CmdExec.execAction 269 , newCmd CmdClean.cleanCommand CmdClean.cleanAction 270 , newCmd CmdSdist.sdistCommand CmdSdist.sdistAction 271 272 , legacyCmd configureExCommand configureAction 273 , legacyCmd updateCommand updateAction 274 , legacyCmd buildCommand buildAction 275 , legacyCmd replCommand replAction 276 , legacyCmd freezeCommand freezeAction 277 , legacyCmd haddockCommand haddockAction 278 , legacyCmd installCommand installAction 279 , legacyCmd runCommand runAction 280 , legacyCmd testCommand testAction 281 , legacyCmd benchmarkCommand benchmarkAction 282 , legacyCmd execCommand execAction 283 , legacyCmd cleanCommand cleanAction 284 , legacyCmd doctestCommand doctestAction 285 , legacyWrapperCmd copyCommand copyVerbosity copyDistPref 286 , legacyWrapperCmd registerCommand regVerbosity regDistPref 287 , legacyCmd reconfigureCommand reconfigureAction 288 ] 289 290type Action = GlobalFlags -> IO () 291 292-- Duplicated in Distribution.Client.CmdLegacy. Any changes must be 293-- reflected there, as well. 294regularCmd :: CommandUI flags -> (flags -> [String] -> action) 295 -> CommandSpec action 296regularCmd ui action = 297 CommandSpec ui ((flip commandAddAction) action) NormalCommand 298 299hiddenCmd :: CommandUI flags -> (flags -> [String] -> action) 300 -> CommandSpec action 301hiddenCmd ui action = 302 CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action)) 303 HiddenCommand 304 305wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) 306 -> (flags -> Flag String) -> CommandSpec Action 307wrapperCmd ui verbosity distPref = 308 CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand 309 310wrapperAction :: Monoid flags 311 => CommandUI flags 312 -> (flags -> Flag Verbosity) 313 -> (flags -> Flag String) 314 -> Command Action 315wrapperAction command verbosityFlag distPrefFlag = 316 commandAddAction command 317 { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do 318 let verbosity = fromFlagOrDefault normal (verbosityFlag flags) 319 load <- try (loadConfigOrSandboxConfig verbosity globalFlags) 320 let config = either (\(SomeException _) -> mempty) id load 321 distPref <- findSavedDistPref config (distPrefFlag flags) 322 let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } 323 setupWrapper verbosity setupScriptOptions Nothing 324 command (const flags) (const extraArgs) 325 326configureAction :: (ConfigFlags, ConfigExFlags) 327 -> [String] -> Action 328configureAction (configFlags, configExFlags) extraArgs globalFlags = do 329 let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) 330 config <- updateInstallDirs (configUserInstall configFlags) 331 <$> loadConfigOrSandboxConfig verbosity globalFlags 332 distPref <- findSavedDistPref config (configDistPref configFlags) 333 nixInstantiate verbosity distPref True globalFlags config 334 nixShell verbosity distPref globalFlags config $ do 335 let configFlags' = savedConfigureFlags config `mappend` configFlags 336 configExFlags' = savedConfigureExFlags config `mappend` configExFlags 337 globalFlags' = savedGlobalFlags config `mappend` globalFlags 338 (comp, platform, progdb) <- configCompilerAuxEx configFlags' 339 340 writeConfigFlags verbosity distPref (configFlags', configExFlags') 341 342 -- What package database(s) to use 343 let packageDBs :: PackageDBStack 344 packageDBs 345 = interpretPackageDbFlags 346 (fromFlag (configUserInstall configFlags')) 347 (configPackageDBs configFlags') 348 349 withRepoContext verbosity globalFlags' $ \repoContext -> 350 configure verbosity packageDBs repoContext 351 comp platform progdb configFlags' configExFlags' extraArgs 352 353reconfigureAction :: (ConfigFlags, ConfigExFlags) 354 -> [String] -> Action 355reconfigureAction flags@(configFlags, _) _ globalFlags = do 356 let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) 357 config <- updateInstallDirs (configUserInstall configFlags) 358 <$> loadConfigOrSandboxConfig verbosity globalFlags 359 distPref <- findSavedDistPref config (configDistPref configFlags) 360 let checkFlags = Check $ \_ saved -> do 361 let flags' = saved <> flags 362 unless (saved == flags') $ info verbosity message 363 pure (Any True, flags') 364 where 365 -- This message is correct, but not very specific: it will list all 366 -- of the new flags, even if some have not actually changed. The 367 -- *minimal* set of changes is more difficult to determine. 368 message = 369 "flags changed: " 370 ++ unwords (commandShowOptions configureExCommand flags) 371 nixInstantiate verbosity distPref True globalFlags config 372 _ <- 373 reconfigure configureAction 374 verbosity distPref NoFlag 375 checkFlags [] globalFlags config 376 pure () 377 378buildAction :: BuildFlags -> [String] -> Action 379buildAction buildFlags extraArgs globalFlags = do 380 let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) 381 config <- loadConfigOrSandboxConfig verbosity globalFlags 382 distPref <- findSavedDistPref config (buildDistPref buildFlags) 383 -- Calls 'configureAction' to do the real work, so nothing special has to be 384 -- done to support sandboxes. 385 config' <- 386 reconfigure configureAction 387 verbosity distPref (buildNumJobs buildFlags) 388 mempty [] globalFlags config 389 nixShell verbosity distPref globalFlags config $ do 390 build verbosity config' distPref buildFlags extraArgs 391 392 393-- | Actually do the work of building the package. This is separate from 394-- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke 395-- 'reconfigure' twice. 396build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO () 397build verbosity config distPref buildFlags extraArgs = 398 setupWrapper verbosity setupOptions Nothing 399 (Cabal.buildCommand progDb) mkBuildFlags (const extraArgs) 400 where 401 progDb = defaultProgramDb 402 setupOptions = defaultSetupScriptOptions { useDistPref = distPref } 403 404 mkBuildFlags version = filterBuildFlags version config buildFlags' 405 buildFlags' = buildFlags 406 { buildVerbosity = toFlag verbosity 407 , buildDistPref = toFlag distPref 408 } 409 410-- | Make sure that we don't pass new flags to setup scripts compiled against 411-- old versions of Cabal. 412filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags 413filterBuildFlags version config buildFlags 414 | version >= mkVersion [1,19,1] = buildFlags_latest 415 -- Cabal < 1.19.1 doesn't support 'build -j'. 416 | otherwise = buildFlags_pre_1_19_1 417 where 418 buildFlags_pre_1_19_1 = buildFlags { 419 buildNumJobs = NoFlag 420 } 421 buildFlags_latest = buildFlags { 422 -- Take the 'jobs' setting '~/.cabal/config' into account. 423 buildNumJobs = Flag . Just . determineNumJobs $ 424 (numJobsConfigFlag `mappend` numJobsCmdLineFlag) 425 } 426 numJobsConfigFlag = installNumJobs . savedInstallFlags $ config 427 numJobsCmdLineFlag = buildNumJobs buildFlags 428 429 430replAction :: ReplFlags -> [String] -> Action 431replAction replFlags extraArgs globalFlags = do 432 let verbosity = fromFlagOrDefault normal (replVerbosity replFlags) 433 config <- loadConfigOrSandboxConfig verbosity globalFlags 434 distPref <- findSavedDistPref config (replDistPref replFlags) 435 cwd <- getCurrentDirectory 436 pkgDesc <- findPackageDesc cwd 437 let 438 -- There is a .cabal file in the current directory: start a REPL and load 439 -- the project's modules. 440 onPkgDesc = do 441 -- Calls 'configureAction' to do the real work, so nothing special has to 442 -- be done to support sandboxes. 443 _ <- 444 reconfigure configureAction 445 verbosity distPref NoFlag 446 mempty [] globalFlags config 447 let progDb = defaultProgramDb 448 setupOptions = defaultSetupScriptOptions 449 { useCabalVersion = orLaterVersion $ mkVersion [1,18,0] 450 , useDistPref = distPref 451 } 452 replFlags' = replFlags 453 { replVerbosity = toFlag verbosity 454 , replDistPref = toFlag distPref 455 } 456 457 nixShell verbosity distPref globalFlags config $ 458 setupWrapper verbosity setupOptions Nothing (Cabal.replCommand progDb) (const replFlags') (const extraArgs) 459 460 -- No .cabal file in the current directory: just start the REPL (possibly 461 -- using the sandbox package DB). 462 onNoPkgDesc = do 463 let configFlags = savedConfigureFlags config 464 (comp, platform, programDb) <- configCompilerAux' configFlags 465 programDb' <- reconfigurePrograms verbosity 466 (replProgramPaths replFlags) 467 (replProgramArgs replFlags) 468 programDb 469 nixShell verbosity distPref globalFlags config $ do 470 startInterpreter verbosity programDb' comp platform 471 (configPackageDB' configFlags) 472 473 either (const onNoPkgDesc) (const onPkgDesc) pkgDesc 474 475installAction :: ( ConfigFlags, ConfigExFlags, InstallFlags 476 , HaddockFlags, TestFlags, BenchmarkFlags ) 477 -> [String] -> Action 478installAction (configFlags, _, installFlags, _, _, _) _ globalFlags 479 | fromFlagOrDefault False (installOnly installFlags) = do 480 let verb = fromFlagOrDefault normal (configVerbosity configFlags) 481 config <- loadConfigOrSandboxConfig verb globalFlags 482 dist <- findSavedDistPref config (configDistPref configFlags) 483 let setupOpts = defaultSetupScriptOptions { useDistPref = dist } 484 setupWrapper 485 verb setupOpts Nothing 486 installCommand (const (mempty, mempty, mempty, mempty, mempty, mempty)) 487 (const []) 488 489installAction 490 ( configFlags, configExFlags, installFlags 491 , haddockFlags, testFlags, benchmarkFlags ) 492 extraArgs globalFlags = do 493 let verb = fromFlagOrDefault normal (configVerbosity configFlags) 494 config <- updateInstallDirs (configUserInstall configFlags) 495 <$> loadConfigOrSandboxConfig verb globalFlags 496 497 dist <- findSavedDistPref config (configDistPref configFlags) 498 499 do 500 targets <- readUserTargets verb extraArgs 501 502 let configFlags' = maybeForceTests installFlags' $ 503 savedConfigureFlags config `mappend` 504 configFlags { configDistPref = toFlag dist } 505 configExFlags' = defaultConfigExFlags `mappend` 506 savedConfigureExFlags config `mappend` configExFlags 507 installFlags' = defaultInstallFlags `mappend` 508 savedInstallFlags config `mappend` installFlags 509 haddockFlags' = defaultHaddockFlags `mappend` 510 savedHaddockFlags config `mappend` 511 haddockFlags { haddockDistPref = toFlag dist } 512 testFlags' = Cabal.defaultTestFlags `mappend` 513 savedTestFlags config `mappend` 514 testFlags { testDistPref = toFlag dist } 515 benchmarkFlags' = Cabal.defaultBenchmarkFlags `mappend` 516 savedBenchmarkFlags config `mappend` 517 benchmarkFlags { benchmarkDistPref = toFlag dist } 518 globalFlags' = savedGlobalFlags config `mappend` globalFlags 519 (comp, platform, progdb) <- configCompilerAux' configFlags' 520 521 -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the 522 -- future. 523 progdb' <- configureAllKnownPrograms verb progdb 524 525 configFlags'' <- configAbsolutePaths configFlags' 526 527 withRepoContext verb globalFlags' $ \repoContext -> 528 install verb 529 (configPackageDB' configFlags'') 530 repoContext 531 comp platform progdb' 532 globalFlags' configFlags'' configExFlags' 533 installFlags' haddockFlags' testFlags' benchmarkFlags' 534 targets 535 536 where 537 -- '--run-tests' implies '--enable-tests'. 538 maybeForceTests installFlags' configFlags' = 539 if fromFlagOrDefault False (installRunTests installFlags') 540 then configFlags' { configTests = toFlag True } 541 else configFlags' 542 543testAction :: (BuildFlags, TestFlags) -> [String] -> GlobalFlags 544 -> IO () 545testAction (buildFlags, testFlags) extraArgs globalFlags = do 546 let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) 547 config <- loadConfigOrSandboxConfig verbosity globalFlags 548 distPref <- findSavedDistPref config (testDistPref testFlags) 549 let buildFlags' = buildFlags 550 { buildVerbosity = testVerbosity testFlags } 551 checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> 552 if fromFlagOrDefault False (configTests configFlags) 553 then pure (mempty, flags) 554 else do 555 info verbosity "reconfiguring to enable tests" 556 let flags' = ( configFlags { configTests = toFlag True } 557 , configExFlags 558 ) 559 pure (Any True, flags') 560 561 _ <- 562 reconfigure configureAction 563 verbosity distPref (buildNumJobs buildFlags') 564 checkFlags [] globalFlags config 565 nixShell verbosity distPref globalFlags config $ do 566 let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } 567 testFlags' = testFlags { testDistPref = toFlag distPref } 568 569 -- The package was just configured, so the LBI must be available. 570 names <- componentNamesFromLBI verbosity distPref "test suites" 571 (\c -> case c of { LBI.CTest{} -> True; _ -> False }) 572 let extraArgs' 573 | null extraArgs = case names of 574 ComponentNamesUnknown -> [] 575 ComponentNames names' -> [ Make.unUnqualComponentName name 576 | LBI.CTestName name <- names' ] 577 | otherwise = extraArgs 578 579 build verbosity config distPref buildFlags' extraArgs' 580 setupWrapper verbosity setupOptions Nothing Cabal.testCommand (const testFlags') (const extraArgs') 581 582data ComponentNames = ComponentNamesUnknown 583 | ComponentNames [LBI.ComponentName] 584 585-- | Return the names of all buildable components matching a given predicate. 586componentNamesFromLBI :: Verbosity -> FilePath -> String 587 -> (LBI.Component -> Bool) 588 -> IO ComponentNames 589componentNamesFromLBI verbosity distPref targetsDescr compPred = do 590 eLBI <- tryGetPersistBuildConfig distPref 591 case eLBI of 592 Left err -> case err of 593 -- Note: the build config could have been generated by a custom setup 594 -- script built against a different Cabal version, so it's crucial that 595 -- we ignore the bad version error here. 596 ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown 597 _ -> die' verbosity (show err) 598 Right lbi -> do 599 let pkgDescr = LBI.localPkgDescr lbi 600 names = map LBI.componentName 601 . filter (buildable . LBI.componentBuildInfo) 602 . filter compPred $ 603 LBI.pkgComponents pkgDescr 604 if null names 605 then do notice verbosity $ "Package has no buildable " 606 ++ targetsDescr ++ "." 607 exitSuccess -- See #3215. 608 609 else return $! (ComponentNames names) 610 611benchmarkAction :: (BuildFlags, BenchmarkFlags) 612 -> [String] -> GlobalFlags 613 -> IO () 614benchmarkAction 615 (buildFlags, benchmarkFlags) 616 extraArgs globalFlags = do 617 let verbosity = fromFlagOrDefault normal 618 (buildVerbosity buildFlags) 619 620 config <- loadConfigOrSandboxConfig verbosity globalFlags 621 distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags) 622 let buildFlags' = buildFlags 623 { buildVerbosity = benchmarkVerbosity benchmarkFlags } 624 625 let checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> 626 if fromFlagOrDefault False (configBenchmarks configFlags) 627 then pure (mempty, flags) 628 else do 629 info verbosity "reconfiguring to enable benchmarks" 630 let flags' = ( configFlags { configBenchmarks = toFlag True } 631 , configExFlags 632 ) 633 pure (Any True, flags') 634 635 config' <- 636 reconfigure configureAction 637 verbosity distPref (buildNumJobs buildFlags') 638 checkFlags [] globalFlags config 639 nixShell verbosity distPref globalFlags config $ do 640 let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } 641 benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref } 642 643 -- The package was just configured, so the LBI must be available. 644 names <- componentNamesFromLBI verbosity distPref "benchmarks" 645 (\c -> case c of { LBI.CBench{} -> True; _ -> False; }) 646 let extraArgs' 647 | null extraArgs = case names of 648 ComponentNamesUnknown -> [] 649 ComponentNames names' -> [ Make.unUnqualComponentName name 650 | LBI.CBenchName name <- names'] 651 | otherwise = extraArgs 652 653 build verbosity config' distPref buildFlags' extraArgs' 654 setupWrapper verbosity setupOptions Nothing Cabal.benchmarkCommand (const benchmarkFlags') (const extraArgs') 655 656haddockAction :: HaddockFlags -> [String] -> Action 657haddockAction haddockFlags extraArgs globalFlags = do 658 let verbosity = fromFlag (haddockVerbosity haddockFlags) 659 config <- loadConfigOrSandboxConfig verbosity globalFlags 660 distPref <- findSavedDistPref config (haddockDistPref haddockFlags) 661 config' <- 662 reconfigure configureAction 663 verbosity distPref NoFlag 664 mempty [] globalFlags config 665 nixShell verbosity distPref globalFlags config $ do 666 let haddockFlags' = defaultHaddockFlags `mappend` 667 savedHaddockFlags config' `mappend` 668 haddockFlags { haddockDistPref = toFlag distPref } 669 setupScriptOptions = defaultSetupScriptOptions 670 { useDistPref = distPref } 671 setupWrapper verbosity setupScriptOptions Nothing 672 haddockCommand (const haddockFlags') (const extraArgs) 673 when (haddockForHackage haddockFlags == Flag ForHackage) $ do 674 pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) 675 let dest = distPref </> name <.> "tar.gz" 676 name = display (packageId pkg) ++ "-docs" 677 docDir = distPref </> "doc" </> "html" 678 createTarGzFile dest docDir name 679 notice verbosity $ "Documentation tarball created: " ++ dest 680 681doctestAction :: DoctestFlags -> [String] -> Action 682doctestAction doctestFlags extraArgs _globalFlags = do 683 let verbosity = fromFlag (doctestVerbosity doctestFlags) 684 685 setupWrapper verbosity defaultSetupScriptOptions Nothing 686 doctestCommand (const doctestFlags) (const extraArgs) 687 688cleanAction :: CleanFlags -> [String] -> Action 689cleanAction cleanFlags extraArgs globalFlags = do 690 load <- try (loadConfigOrSandboxConfig verbosity globalFlags) 691 let config = either (\(SomeException _) -> mempty) id load 692 distPref <- findSavedDistPref config (cleanDistPref cleanFlags) 693 let setupScriptOptions = defaultSetupScriptOptions 694 { useDistPref = distPref 695 , useWin32CleanHack = True 696 } 697 cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref } 698 setupWrapper verbosity setupScriptOptions Nothing 699 cleanCommand (const cleanFlags') (const extraArgs) 700 where 701 verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags) 702 703listAction :: ListFlags -> [String] -> Action 704listAction listFlags extraArgs globalFlags = do 705 let verbosity = fromFlag (listVerbosity listFlags) 706 config <- loadConfigOrSandboxConfig verbosity globalFlags 707 let configFlags' = savedConfigureFlags config 708 configFlags = configFlags' 709 { configPackageDBs = configPackageDBs configFlags' 710 `mappend` listPackageDBs listFlags 711 , configHcPath = listHcPath listFlags 712 } 713 globalFlags' = savedGlobalFlags config `mappend` globalFlags 714 compProgdb <- if listNeedsCompiler listFlags 715 then do 716 (comp, _, progdb) <- configCompilerAux' configFlags 717 return (Just (comp, progdb)) 718 else return Nothing 719 withRepoContext verbosity globalFlags' $ \repoContext -> 720 List.list verbosity 721 (configPackageDB' configFlags) 722 repoContext 723 compProgdb 724 listFlags 725 extraArgs 726 727infoAction :: InfoFlags -> [String] -> Action 728infoAction infoFlags extraArgs globalFlags = do 729 let verbosity = fromFlag (infoVerbosity infoFlags) 730 targets <- readUserTargets verbosity extraArgs 731 config <- loadConfigOrSandboxConfig verbosity globalFlags 732 let configFlags' = savedConfigureFlags config 733 configFlags = configFlags' { 734 configPackageDBs = configPackageDBs configFlags' 735 `mappend` infoPackageDBs infoFlags 736 } 737 globalFlags' = savedGlobalFlags config `mappend` globalFlags 738 (comp, _, progdb) <- configCompilerAuxEx configFlags 739 withRepoContext verbosity globalFlags' $ \repoContext -> 740 List.info verbosity 741 (configPackageDB' configFlags) 742 repoContext 743 comp 744 progdb 745 globalFlags' 746 infoFlags 747 targets 748 749updateAction :: UpdateFlags -> [String] -> Action 750updateAction updateFlags extraArgs globalFlags = do 751 let verbosity = fromFlag (updateVerbosity updateFlags) 752 unless (null extraArgs) $ 753 die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs 754 config <- loadConfigOrSandboxConfig verbosity globalFlags 755 let globalFlags' = savedGlobalFlags config `mappend` globalFlags 756 withRepoContext verbosity globalFlags' $ \repoContext -> 757 update verbosity updateFlags repoContext 758 759fetchAction :: FetchFlags -> [String] -> Action 760fetchAction fetchFlags extraArgs globalFlags = do 761 let verbosity = fromFlag (fetchVerbosity fetchFlags) 762 targets <- readUserTargets verbosity extraArgs 763 config <- loadConfig verbosity (globalConfigFile globalFlags) 764 let configFlags = savedConfigureFlags config 765 globalFlags' = savedGlobalFlags config `mappend` globalFlags 766 (comp, platform, progdb) <- configCompilerAux' configFlags 767 withRepoContext verbosity globalFlags' $ \repoContext -> 768 fetch verbosity 769 (configPackageDB' configFlags) 770 repoContext 771 comp platform progdb globalFlags' fetchFlags 772 targets 773 774freezeAction :: FreezeFlags -> [String] -> Action 775freezeAction freezeFlags _extraArgs globalFlags = do 776 let verbosity = fromFlag (freezeVerbosity freezeFlags) 777 config <- loadConfigOrSandboxConfig verbosity globalFlags 778 distPref <- findSavedDistPref config NoFlag 779 nixShell verbosity distPref globalFlags config $ do 780 let configFlags = savedConfigureFlags config 781 globalFlags' = savedGlobalFlags config `mappend` globalFlags 782 (comp, platform, progdb) <- configCompilerAux' configFlags 783 784 withRepoContext verbosity globalFlags' $ \repoContext -> 785 freeze verbosity 786 (configPackageDB' configFlags) 787 repoContext 788 comp platform progdb 789 globalFlags' freezeFlags 790 791genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () 792genBoundsAction freezeFlags _extraArgs globalFlags = do 793 let verbosity = fromFlag (freezeVerbosity freezeFlags) 794 config <- loadConfigOrSandboxConfig verbosity globalFlags 795 distPref <- findSavedDistPref config NoFlag 796 nixShell verbosity distPref globalFlags config $ do 797 let configFlags = savedConfigureFlags config 798 globalFlags' = savedGlobalFlags config `mappend` globalFlags 799 (comp, platform, progdb) <- configCompilerAux' configFlags 800 801 withRepoContext verbosity globalFlags' $ \repoContext -> 802 genBounds verbosity 803 (configPackageDB' configFlags) 804 repoContext 805 comp platform progdb 806 globalFlags' freezeFlags 807 808outdatedAction :: OutdatedFlags -> [String] -> GlobalFlags -> IO () 809outdatedAction outdatedFlags _extraArgs globalFlags = do 810 let verbosity = fromFlag (outdatedVerbosity outdatedFlags) 811 config <- loadConfigOrSandboxConfig verbosity globalFlags 812 let configFlags = savedConfigureFlags config 813 globalFlags' = savedGlobalFlags config `mappend` globalFlags 814 (comp, platform, _progdb) <- configCompilerAux' configFlags 815 withRepoContext verbosity globalFlags' $ \repoContext -> 816 outdated verbosity outdatedFlags repoContext 817 comp platform 818 819uploadAction :: UploadFlags -> [String] -> Action 820uploadAction uploadFlags extraArgs globalFlags = do 821 config <- loadConfig verbosity (globalConfigFile globalFlags) 822 let uploadFlags' = savedUploadFlags config `mappend` uploadFlags 823 globalFlags' = savedGlobalFlags config `mappend` globalFlags 824 tarfiles = extraArgs 825 when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $ 826 die' verbosity "the 'upload' command expects at least one .tar.gz archive." 827 checkTarFiles extraArgs 828 maybe_password <- 829 case uploadPasswordCmd uploadFlags' 830 of Flag (xs:xss) -> Just . Password <$> 831 getProgramInvocationOutput verbosity 832 (simpleProgramInvocation xs xss) 833 _ -> pure $ flagToMaybe $ uploadPassword uploadFlags' 834 withRepoContext verbosity globalFlags' $ \repoContext -> do 835 if fromFlag (uploadDoc uploadFlags') 836 then do 837 when (length tarfiles > 1) $ 838 die' verbosity $ "the 'upload' command can only upload documentation " 839 ++ "for one package at a time." 840 tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles 841 Upload.uploadDoc verbosity 842 repoContext 843 (flagToMaybe $ uploadUsername uploadFlags') 844 maybe_password 845 (fromFlag (uploadCandidate uploadFlags')) 846 tarfile 847 else do 848 Upload.upload verbosity 849 repoContext 850 (flagToMaybe $ uploadUsername uploadFlags') 851 maybe_password 852 (fromFlag (uploadCandidate uploadFlags')) 853 tarfiles 854 where 855 verbosity = fromFlag (uploadVerbosity uploadFlags) 856 checkTarFiles tarfiles 857 | not (null otherFiles) 858 = die' verbosity $ "the 'upload' command expects only .tar.gz archives: " 859 ++ intercalate ", " otherFiles 860 | otherwise = sequence_ 861 [ do exists <- doesFileExist tarfile 862 unless exists $ die' verbosity $ "file not found: " ++ tarfile 863 | tarfile <- tarfiles ] 864 865 where otherFiles = filter (not . isTarGzFile) tarfiles 866 isTarGzFile file = case splitExtension file of 867 (file', ".gz") -> takeExtension file' == ".tar" 868 _ -> False 869 generateDocTarball config = do 870 notice verbosity $ 871 "No documentation tarball specified. " 872 ++ "Building a documentation tarball with default settings...\n" 873 ++ "If you need to customise Haddock options, " 874 ++ "run 'haddock --for-hackage' first " 875 ++ "to generate a documentation tarball." 876 haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage }) 877 [] globalFlags 878 distPref <- findSavedDistPref config NoFlag 879 pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) 880 return $ distPref </> display (packageId pkg) ++ "-docs" <.> "tar.gz" 881 882checkAction :: Flag Verbosity -> [String] -> Action 883checkAction verbosityFlag extraArgs _globalFlags = do 884 let verbosity = fromFlag verbosityFlag 885 unless (null extraArgs) $ 886 die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs 887 allOk <- Check.check (fromFlag verbosityFlag) 888 unless allOk exitFailure 889 890formatAction :: Flag Verbosity -> [String] -> Action 891formatAction verbosityFlag extraArgs _globalFlags = do 892 let verbosity = fromFlag verbosityFlag 893 path <- case extraArgs of 894 [] -> do cwd <- getCurrentDirectory 895 tryFindPackageDesc verbosity cwd 896 (p:_) -> return p 897 pkgDesc <- readGenericPackageDescription verbosity path 898 -- Uses 'writeFileAtomic' under the hood. 899 writeGenericPackageDescription path pkgDesc 900 901reportAction :: ReportFlags -> [String] -> Action 902reportAction reportFlags extraArgs globalFlags = do 903 let verbosity = fromFlag (reportVerbosity reportFlags) 904 unless (null extraArgs) $ 905 die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs 906 config <- loadConfig verbosity (globalConfigFile globalFlags) 907 let globalFlags' = savedGlobalFlags config `mappend` globalFlags 908 reportFlags' = savedReportFlags config `mappend` reportFlags 909 910 withRepoContext verbosity globalFlags' $ \repoContext -> 911 Upload.report verbosity repoContext 912 (flagToMaybe $ reportUsername reportFlags') 913 (flagToMaybe $ reportPassword reportFlags') 914 915runAction :: BuildFlags -> [String] -> Action 916runAction buildFlags extraArgs globalFlags = do 917 let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) 918 config <- loadConfigOrSandboxConfig verbosity globalFlags 919 distPref <- findSavedDistPref config (buildDistPref buildFlags) 920 config' <- 921 reconfigure configureAction 922 verbosity distPref (buildNumJobs buildFlags) 923 mempty [] globalFlags config 924 nixShell verbosity distPref globalFlags config $ do 925 lbi <- getPersistBuildConfig distPref 926 (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs 927 928 build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)] 929 run verbosity lbi exe exeArgs 930 931getAction :: GetFlags -> [String] -> Action 932getAction getFlags extraArgs globalFlags = do 933 let verbosity = fromFlag (getVerbosity getFlags) 934 targets <- readUserTargets verbosity extraArgs 935 config <- loadConfigOrSandboxConfig verbosity globalFlags 936 let globalFlags' = savedGlobalFlags config `mappend` globalFlags 937 withRepoContext verbosity (savedGlobalFlags config) $ \repoContext -> 938 get verbosity 939 repoContext 940 globalFlags' 941 getFlags 942 targets 943 944unpackAction :: GetFlags -> [String] -> Action 945unpackAction getFlags extraArgs globalFlags = do 946 getAction getFlags extraArgs globalFlags 947 948initAction :: InitFlags -> [String] -> Action 949initAction initFlags extraArgs globalFlags = do 950 let verbosity = fromFlag (initVerbosity initFlags) 951 when (extraArgs /= []) $ 952 die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs 953 config <- loadConfigOrSandboxConfig verbosity globalFlags 954 let configFlags = savedConfigureFlags config `mappend` 955 -- override with `--with-compiler` from CLI if available 956 mempty { configHcPath = initHcPath initFlags } 957 let initFlags' = savedInitFlags config `mappend` initFlags 958 let globalFlags' = savedGlobalFlags config `mappend` globalFlags 959 (comp, _, progdb) <- configCompilerAux' configFlags 960 withRepoContext verbosity globalFlags' $ \repoContext -> 961 initCabal verbosity 962 (configPackageDB' configFlags) 963 repoContext 964 comp 965 progdb 966 initFlags' 967 968execAction :: ExecFlags -> [String] -> Action 969execAction execFlags extraArgs globalFlags = do 970 let verbosity = fromFlag (execVerbosity execFlags) 971 config <- loadConfigOrSandboxConfig verbosity globalFlags 972 distPref <- findSavedDistPref config (execDistPref execFlags) 973 let configFlags = savedConfigureFlags config 974 configFlags' = configFlags { configDistPref = Flag distPref } 975 (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags' 976 exec verbosity comp platform progdb extraArgs 977 978userConfigAction :: UserConfigFlags -> [String] -> Action 979userConfigAction ucflags extraArgs globalFlags = do 980 let verbosity = fromFlag (userConfigVerbosity ucflags) 981 frc = fromFlag (userConfigForce ucflags) 982 extraLines = fromFlag (userConfigAppendLines ucflags) 983 case extraArgs of 984 ("init":_) -> do 985 path <- configFile 986 fileExists <- doesFileExist path 987 if (not fileExists || (fileExists && frc)) 988 then void $ createDefaultConfigFile verbosity extraLines path 989 else die' verbosity $ path ++ " already exists." 990 ("diff":_) -> traverse_ putStrLn =<< userConfigDiff verbosity globalFlags extraLines 991 ("update":_) -> userConfigUpdate verbosity globalFlags extraLines 992 -- Error handling. 993 [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')" 994 _ -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs 995 where configFile = getConfigFilePath (globalConfigFile globalFlags) 996 997-- | Used as an entry point when cabal-install needs to invoke itself 998-- as a setup script. This can happen e.g. when doing parallel builds. 999-- 1000actAsSetupAction :: ActAsSetupFlags -> [String] -> Action 1001actAsSetupAction actAsSetupFlags args _globalFlags = 1002 let bt = fromFlag (actAsSetupBuildType actAsSetupFlags) 1003 in case bt of 1004 Simple -> Simple.defaultMainArgs args 1005 Configure -> Simple.defaultMainWithHooksArgs 1006 Simple.autoconfUserHooks args 1007 Make -> Make.defaultMainArgs args 1008 Custom -> error "actAsSetupAction Custom" 1009 1010manpageAction :: [CommandSpec action] -> ManpageFlags -> [String] -> Action 1011manpageAction commands flags extraArgs _ = do 1012 let verbosity = fromFlag (manpageVerbosity flags) 1013 unless (null extraArgs) $ 1014 die' verbosity $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs 1015 pname <- getProgName 1016 let cabalCmd = if takeExtension pname == ".exe" 1017 then dropExtension pname 1018 else pname 1019 manpageCmd cabalCmd commands flags 1020