diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -1,7 +1,7 @@ Cabal-Version: 2.2 Name: cabal-install -Version: 3.10.1.0 +Version: 3.10.2.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing @@ -46,7 +46,7 @@ ghc-options: -Wunused-packages common base-dep - build-depends: base >=4.10 && <4.18 + build-depends: base >=4.10 && <4.19 common cabal-dep build-depends: Cabal ^>=3.10 @@ -140,6 +140,7 @@ Distribution.Client.InstallSymlink Distribution.Client.JobControl Distribution.Client.List + Distribution.Client.Main Distribution.Client.Manpage Distribution.Client.ManpageFlags Distribution.Client.Nix @@ -204,6 +205,7 @@ async >= 2.0 && < 2.3, array >= 0.4 && < 0.6, base16-bytestring >= 0.1.1 && < 1.1.0.0, + base64-bytestring >= 1.0 && < 1.3, binary >= 0.7.3 && < 0.9, bytestring >= 0.10.6.0 && < 0.12, containers >= 0.5.6.2 && < 0.7, @@ -235,7 +237,7 @@ if os(windows) build-depends: windns >= 0.1.0 && < 0.2 else - build-depends: resolv >= 0.1.1 && < 0.2 + build-depends: resolv >= 0.1.1 && < 0.3 if os(windows) -- newer directory for symlinks @@ -252,7 +254,7 @@ executable cabal - import: warnings, base-dep, cabal-dep, cabal-syntax-dep + import: warnings, base-dep main-is: Main.hs hs-source-dirs: main default-language: Haskell2010 @@ -264,9 +266,7 @@ extra-libraries: bsd build-depends: - cabal-install, - directory, - filepath + cabal-install -- Small, fast running tests. -- @@ -335,7 +335,7 @@ tasty-quickcheck, tasty-hunit >= 0.10, tree-diff, - QuickCheck >= 2.14 && <2.15 + QuickCheck >= 2.14.3 && <2.15 -- Tests to run with a limited stack and heap size diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,8 @@ -*-change-log-*- +3.10.2.0 Hécate August 2023 + * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.10.2.0.md + 3.10.1.0 Mikolaj Konarski March 2023 * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.10.1.0.md diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -1,1010 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} - ------------------------------------------------------------------------------ --- | --- Module : Main --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- Entry point to the default cabal-install front-end. ------------------------------------------------------------------------------ - -module Main (main) where - -import Distribution.Client.Setup - ( GlobalFlags(..), globalCommand, withRepoContext - , ConfigFlags(..) - , ConfigExFlags(..), defaultConfigExFlags, configureExCommand - , reconfigureCommand - , configCompilerAux', configPackageDB' - , BuildFlags(..) - , buildCommand, replCommand, testCommand, benchmarkCommand - , InstallFlags(..), defaultInstallFlags - , installCommand - , FetchFlags(..), fetchCommand - , FreezeFlags(..), freezeCommand - , genBoundsCommand - , GetFlags(..), getCommand, unpackCommand - , checkCommand - , formatCommand - , ListFlags(..), listCommand, listNeedsCompiler - , InfoFlags(..), infoCommand - , UploadFlags(..), uploadCommand - , ReportFlags(..), reportCommand - , runCommand - , InitFlags(initVerbosity, initHcPath), initCommand - , ActAsSetupFlags(..), actAsSetupCommand - , UserConfigFlags(..), userConfigCommand - , reportCommand - , manpageCommand - , haddockCommand - , cleanCommand - , copyCommand - , registerCommand - ) -import Distribution.Simple.Setup - ( HaddockTarget(..) - , HaddockFlags(..), defaultHaddockFlags - , HscolourFlags(..), hscolourCommand - , ReplFlags(..) - , CopyFlags(..) - , RegisterFlags(..) - , CleanFlags(..) - , TestFlags(..), BenchmarkFlags(..) - , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag - , configAbsolutePaths - ) - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (get) - -import Distribution.Client.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) -import Distribution.Client.Config - ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff - , userConfigUpdate, createDefaultConfigFile, getConfigFilePath ) -import Distribution.Client.Targets - ( readUserTargets ) -import qualified Distribution.Client.List as List - ( list, info ) - -import qualified Distribution.Client.CmdConfigure as CmdConfigure -import qualified Distribution.Client.CmdUpdate as CmdUpdate -import qualified Distribution.Client.CmdBuild as CmdBuild -import qualified Distribution.Client.CmdRepl as CmdRepl -import qualified Distribution.Client.CmdFreeze as CmdFreeze -import qualified Distribution.Client.CmdHaddock as CmdHaddock -import qualified Distribution.Client.CmdHaddockProject as CmdHaddockProject -import qualified Distribution.Client.CmdInstall as CmdInstall -import qualified Distribution.Client.CmdRun as CmdRun -import qualified Distribution.Client.CmdTest as CmdTest -import qualified Distribution.Client.CmdBench as CmdBench -import qualified Distribution.Client.CmdExec as CmdExec -import qualified Distribution.Client.CmdClean as CmdClean -import qualified Distribution.Client.CmdSdist as CmdSdist -import qualified Distribution.Client.CmdListBin as CmdListBin -import qualified Distribution.Client.CmdOutdated as CmdOutdated -import Distribution.Client.CmdLegacy - -import Distribution.Client.Install (install) -import Distribution.Client.Configure (configure, writeConfigFlags) -import Distribution.Client.Fetch (fetch) -import Distribution.Client.Freeze (freeze) -import Distribution.Client.GenBounds (genBounds) -import Distribution.Client.Check as Check (check) ---import Distribution.Client.Clean (clean) -import qualified Distribution.Client.Upload as Upload -import Distribution.Client.Run (run, splitRunArgs) -import Distribution.Client.Get (get) -import Distribution.Client.Reconfigure (Check(..), reconfigure) -import Distribution.Client.Nix (nixInstantiate - ,nixShell - ) -import Distribution.Client.Sandbox (loadConfigOrSandboxConfig - ,findSavedDistPref - ,updateInstallDirs) -import Distribution.Client.Tar (createTarGzFile) -import Distribution.Client.Types.Credentials (Password (..)) -import Distribution.Client.Init (initCmd) -import Distribution.Client.Manpage (manpageCmd) -import Distribution.Client.ManpageFlags (ManpageFlags (..)) -import Distribution.Client.Utils - ( determineNumJobs, relaxEncodingErrors ) -import Distribution.Client.Signal - ( installTerminationHandler ) -import Distribution.Client.Version - ( cabalInstallVersion ) - -import Distribution.Package (packageId) -import Distribution.PackageDescription - ( BuildType(..), Executable(..), buildable ) - -import Distribution.PackageDescription.PrettyPrint - ( writeGenericPackageDescription ) -import qualified Distribution.Simple as Simple -import qualified Distribution.Make as Make -import qualified Distribution.Types.UnqualComponentName as Make -import Distribution.Simple.Build - ( startInterpreter ) -import Distribution.Simple.Command - ( CommandParse(..), CommandUI(..), Command, CommandSpec(..) - , CommandType(..), commandsRun, commandAddAction, hiddenCommand - , commandFromSpec, commandShowOptions ) -import Distribution.Simple.Compiler (PackageDBStack) -import Distribution.Simple.Configure - ( configCompilerAuxEx, ConfigStateFileError(..) - , getPersistBuildConfig, interpretPackageDbFlags - , tryGetPersistBuildConfig ) -import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.PackageDescription ( readGenericPackageDescription ) -import Distribution.Simple.Program (defaultProgramDb - ,configureAllKnownPrograms - ,simpleProgramInvocation - ,getProgramInvocationOutput) -import Distribution.Simple.Program.Db (reconfigurePrograms) -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Utils - ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler - , findPackageDesc, tryFindPackageDesc, createDirectoryIfMissingVerbose ) -import Distribution.Text - ( display ) -import Distribution.Verbosity as Verbosity - ( normal ) -import Distribution.Version - ( Version, mkVersion, orLaterVersion ) - -import Distribution.Compat.ResponseFile -import System.Environment (getArgs, getProgName) -import System.FilePath ( dropExtension, splitExtension - , takeExtension, (), (<.>) ) -import System.IO ( BufferMode(LineBuffering), hSetBuffering - , hPutStrLn, stderr, stdout ) -import System.Directory ( doesFileExist, getCurrentDirectory - , withCurrentDirectory) -import Data.Monoid (Any(..)) -import Control.Exception (AssertionFailed, assert, try) - - --- | Entry point --- -main :: IO () -main = do - installTerminationHandler - -- Enable line buffering so that we can get fast feedback even when piped. - -- This is especially important for CI and build systems. - hSetBuffering stdout LineBuffering - - -- If the locale encoding for CLI doesn't support all Unicode characters, - -- printing to it may fail unless we relax the handling of encoding errors - -- when writing to stderr and stdout. - relaxEncodingErrors stdout - relaxEncodingErrors stderr - (args0, args1) <- break (== "--") <$> getArgs - mainWorker =<< (++ args1) <$> expandResponse args0 - --- | Check whether assertions are enabled and print a warning in that case. -warnIfAssertionsAreEnabled :: IO () -warnIfAssertionsAreEnabled = - assert False (return ()) `catch` - (\(_e :: AssertionFailed) -> hPutStrLn stderr assertionsEnabledMsg) - -- Andreas, 2022-12-30, issue #8654: - -- The verbosity machinery is not in place at this point (option -v not parsed), - -- so instead of using function @warn@, we print straight to stderr. - where - assertionsEnabledMsg = - "Warning: this is a debug build of cabal-install with assertions enabled." - -mainWorker :: [String] -> IO () -mainWorker args = do - topHandler $ - case commandsRun (globalCommand commands) commands args of - CommandHelp help -> printGlobalHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (globalFlags, commandParse) -> - case commandParse of - _ | fromFlagOrDefault False (globalVersion globalFlags) - -> printVersion - | fromFlagOrDefault False (globalNumericVersion globalFlags) - -> printNumericVersion - CommandHelp help -> printCommandHelp help - CommandList opts -> printOptionsList opts - - CommandErrors errs -> do - -- Check whether cabal is called from a script, like #!/path/to/cabal. - case args of - [] -> printErrors errs - script : scriptArgs -> CmdRun.validScript script >>= \case - False -> printErrors errs - True -> do - -- In main operation (not help, version etc.) print warning if assertions are on. - warnIfAssertionsAreEnabled - CmdRun.handleShebang script scriptArgs - - CommandReadyToGo action -> do - -- In main operation (not help, version etc.) print warning if assertions are on. - warnIfAssertionsAreEnabled - action globalFlags - - where - printCommandHelp help = do - pname <- getProgName - putStr (help pname) - printGlobalHelp help = do - pname <- getProgName - configFile <- defaultConfigFile - putStr (help pname) - putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" - ++ " " ++ configFile ++ "\n" - exists <- doesFileExist configFile - unless exists $ - putStrLn $ "This file will be generated with sensible " - ++ "defaults if you run 'cabal update'." - printOptionsList = putStr . unlines - printErrors errs = dieNoVerbosity $ intercalate "\n" errs - printNumericVersion = putStrLn $ display cabalInstallVersion - printVersion = putStrLn $ "cabal-install version " - ++ display cabalInstallVersion - ++ "\ncompiled using version " - ++ display cabalVersion - ++ " of the Cabal library " - - commands = map commandFromSpec commandSpecs - commandSpecs = - [ regularCmd listCommand listAction - , regularCmd infoCommand infoAction - , regularCmd fetchCommand fetchAction - , regularCmd getCommand getAction - , regularCmd unpackCommand unpackAction - , regularCmd checkCommand checkAction - , regularCmd uploadCommand uploadAction - , regularCmd reportCommand reportAction - , regularCmd initCommand initAction - , regularCmd userConfigCommand userConfigAction - , regularCmd genBoundsCommand genBoundsAction - , regularCmd CmdOutdated.outdatedCommand CmdOutdated.outdatedAction - , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref - , hiddenCmd formatCommand formatAction - , hiddenCmd actAsSetupCommand actAsSetupAction - , hiddenCmd manpageCommand (manpageAction commandSpecs) - , regularCmd CmdListBin.listbinCommand CmdListBin.listbinAction - - ] ++ concat - [ newCmd CmdConfigure.configureCommand CmdConfigure.configureAction - , newCmd CmdUpdate.updateCommand CmdUpdate.updateAction - , newCmd CmdBuild.buildCommand CmdBuild.buildAction - , newCmd CmdRepl.replCommand CmdRepl.replAction - , newCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction - , newCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction - , newCmd CmdHaddockProject.haddockProjectCommand - CmdHaddockProject.haddockProjectAction - , newCmd CmdInstall.installCommand CmdInstall.installAction - , newCmd CmdRun.runCommand CmdRun.runAction - , newCmd CmdTest.testCommand CmdTest.testAction - , newCmd CmdBench.benchCommand CmdBench.benchAction - , newCmd CmdExec.execCommand CmdExec.execAction - , newCmd CmdClean.cleanCommand CmdClean.cleanAction - , newCmd CmdSdist.sdistCommand CmdSdist.sdistAction - - , legacyCmd configureExCommand configureAction - , legacyCmd buildCommand buildAction - , legacyCmd replCommand replAction - , legacyCmd freezeCommand freezeAction - , legacyCmd haddockCommand haddockAction - , legacyCmd installCommand installAction - , legacyCmd runCommand runAction - , legacyCmd testCommand testAction - , legacyCmd benchmarkCommand benchmarkAction - , legacyCmd cleanCommand cleanAction - , legacyWrapperCmd copyCommand copyVerbosity copyDistPref - , legacyWrapperCmd registerCommand regVerbosity regDistPref - , legacyCmd reconfigureCommand reconfigureAction - ] - -type Action = GlobalFlags -> IO () - --- Duplicated in Distribution.Client.CmdLegacy. Any changes must be --- reflected there, as well. -regularCmd :: CommandUI flags -> (flags -> [String] -> action) - -> CommandSpec action -regularCmd ui action = - CommandSpec ui ((flip commandAddAction) action) NormalCommand - -hiddenCmd :: CommandUI flags -> (flags -> [String] -> action) - -> CommandSpec action -hiddenCmd ui action = - CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action)) - HiddenCommand - -wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) - -> (flags -> Flag String) -> CommandSpec Action -wrapperCmd ui verbosity distPref = - CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand - -wrapperAction :: Monoid flags - => CommandUI flags - -> (flags -> Flag Verbosity) - -> (flags -> Flag String) - -> Command Action -wrapperAction command verbosityFlag distPrefFlag = - commandAddAction command - { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do - let verbosity = fromFlagOrDefault normal (verbosityFlag flags) - load <- try (loadConfigOrSandboxConfig verbosity globalFlags) - let config = either (\(SomeException _) -> mempty) id load - distPref <- findSavedDistPref config (distPrefFlag flags) - let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } - setupWrapper verbosity setupScriptOptions Nothing - command (const flags) (const extraArgs) - -configureAction :: (ConfigFlags, ConfigExFlags) - -> [String] -> Action -configureAction (configFlags, configExFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - config <- updateInstallDirs (configUserInstall configFlags) - <$> loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (configDistPref configFlags) - nixInstantiate verbosity distPref True globalFlags config - nixShell verbosity distPref globalFlags config $ do - let configFlags' = savedConfigureFlags config `mappend` configFlags - configExFlags' = savedConfigureExFlags config `mappend` configExFlags - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAuxEx configFlags' - - writeConfigFlags verbosity distPref (configFlags', configExFlags') - - -- What package database(s) to use - let packageDBs :: PackageDBStack - packageDBs - = interpretPackageDbFlags - (fromFlag (configUserInstall configFlags')) - (configPackageDBs configFlags') - - withRepoContext verbosity globalFlags' $ \repoContext -> - configure verbosity packageDBs repoContext - comp platform progdb configFlags' configExFlags' extraArgs - -reconfigureAction :: (ConfigFlags, ConfigExFlags) - -> [String] -> Action -reconfigureAction flags@(configFlags, _) _ globalFlags = do - let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - config <- updateInstallDirs (configUserInstall configFlags) - <$> loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (configDistPref configFlags) - let checkFlags = Check $ \_ saved -> do - let flags' = saved <> flags - unless (saved == flags') $ info verbosity message - pure (Any True, flags') - where - -- This message is correct, but not very specific: it will list all - -- of the new flags, even if some have not actually changed. The - -- *minimal* set of changes is more difficult to determine. - message = - "flags changed: " - ++ unwords (commandShowOptions configureExCommand flags) - nixInstantiate verbosity distPref True globalFlags config - _ <- - reconfigure configureAction - verbosity distPref NoFlag - checkFlags [] globalFlags config - pure () - -buildAction :: BuildFlags -> [String] -> Action -buildAction buildFlags extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) - config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (buildDistPref buildFlags) - -- Calls 'configureAction' to do the real work, so nothing special has to be - -- done to support sandboxes. - config' <- - reconfigure configureAction - verbosity distPref (buildNumJobs buildFlags) - mempty [] globalFlags config - nixShell verbosity distPref globalFlags config $ do - build verbosity config' distPref buildFlags extraArgs - - --- | Actually do the work of building the package. This is separate from --- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke --- 'reconfigure' twice. -build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO () -build verbosity config distPref buildFlags extraArgs = - setupWrapper verbosity setupOptions Nothing - (Cabal.buildCommand progDb) mkBuildFlags (const extraArgs) - where - progDb = defaultProgramDb - setupOptions = defaultSetupScriptOptions { useDistPref = distPref } - - mkBuildFlags version = filterBuildFlags version config buildFlags' - buildFlags' = buildFlags - { buildVerbosity = toFlag verbosity - , buildDistPref = toFlag distPref - } - --- | Make sure that we don't pass new flags to setup scripts compiled against --- old versions of Cabal. -filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags -filterBuildFlags version config buildFlags - | version >= mkVersion [1,19,1] = buildFlags_latest - -- Cabal < 1.19.1 doesn't support 'build -j'. - | otherwise = buildFlags_pre_1_19_1 - where - buildFlags_pre_1_19_1 = buildFlags { - buildNumJobs = NoFlag - } - buildFlags_latest = buildFlags { - -- Take the 'jobs' setting config file into account. - buildNumJobs = Flag . Just . determineNumJobs $ - (numJobsConfigFlag `mappend` numJobsCmdLineFlag) - } - numJobsConfigFlag = installNumJobs . savedInstallFlags $ config - numJobsCmdLineFlag = buildNumJobs buildFlags - - -replAction :: ReplFlags -> [String] -> Action -replAction replFlags extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (replVerbosity replFlags) - config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (replDistPref replFlags) - cwd <- getCurrentDirectory - pkgDesc <- findPackageDesc cwd - let - -- There is a .cabal file in the current directory: start a REPL and load - -- the project's modules. - onPkgDesc = do - -- Calls 'configureAction' to do the real work, so nothing special has to - -- be done to support sandboxes. - _ <- - reconfigure configureAction - verbosity distPref NoFlag - mempty [] globalFlags config - let progDb = defaultProgramDb - setupOptions = defaultSetupScriptOptions - { useCabalVersion = orLaterVersion $ mkVersion [1,18,0] - , useDistPref = distPref - } - replFlags' = replFlags - { replVerbosity = toFlag verbosity - , replDistPref = toFlag distPref - } - - nixShell verbosity distPref globalFlags config $ - setupWrapper verbosity setupOptions Nothing (Cabal.replCommand progDb) (const replFlags') (const extraArgs) - - -- No .cabal file in the current directory: just start the REPL (possibly - -- using the sandbox package DB). - onNoPkgDesc = do - let configFlags = savedConfigureFlags config - (comp, platform, programDb) <- configCompilerAux' configFlags - programDb' <- reconfigurePrograms verbosity - (replProgramPaths replFlags) - (replProgramArgs replFlags) - programDb - nixShell verbosity distPref globalFlags config $ do - startInterpreter verbosity programDb' comp platform - (configPackageDB' configFlags) - - either (const onNoPkgDesc) (const onPkgDesc) pkgDesc - -installAction :: ( ConfigFlags, ConfigExFlags, InstallFlags - , HaddockFlags, TestFlags, BenchmarkFlags ) - -> [String] -> Action -installAction (configFlags, _, installFlags, _, _, _) _ globalFlags - | fromFlagOrDefault False (installOnly installFlags) = do - let verb = fromFlagOrDefault normal (configVerbosity configFlags) - config <- loadConfigOrSandboxConfig verb globalFlags - dist <- findSavedDistPref config (configDistPref configFlags) - let setupOpts = defaultSetupScriptOptions { useDistPref = dist } - setupWrapper - verb setupOpts Nothing - installCommand (const (mempty, mempty, mempty, mempty, mempty, mempty)) - (const []) - -installAction - ( configFlags, configExFlags, installFlags - , haddockFlags, testFlags, benchmarkFlags ) - extraArgs globalFlags = do - let verb = fromFlagOrDefault normal (configVerbosity configFlags) - config <- updateInstallDirs (configUserInstall configFlags) - <$> loadConfigOrSandboxConfig verb globalFlags - - dist <- findSavedDistPref config (configDistPref configFlags) - - do - targets <- readUserTargets verb extraArgs - - let configFlags' = maybeForceTests installFlags' $ - savedConfigureFlags config `mappend` - configFlags { configDistPref = toFlag dist } - configExFlags' = defaultConfigExFlags `mappend` - savedConfigureExFlags config `mappend` configExFlags - installFlags' = defaultInstallFlags `mappend` - savedInstallFlags config `mappend` installFlags - haddockFlags' = defaultHaddockFlags `mappend` - savedHaddockFlags config `mappend` - haddockFlags { haddockDistPref = toFlag dist } - testFlags' = Cabal.defaultTestFlags `mappend` - savedTestFlags config `mappend` - testFlags { testDistPref = toFlag dist } - benchmarkFlags' = Cabal.defaultBenchmarkFlags `mappend` - savedBenchmarkFlags config `mappend` - benchmarkFlags { benchmarkDistPref = toFlag dist } - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAux' configFlags' - - -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the - -- future. - progdb' <- configureAllKnownPrograms verb progdb - - configFlags'' <- configAbsolutePaths configFlags' - - withRepoContext verb globalFlags' $ \repoContext -> - install verb - (configPackageDB' configFlags'') - repoContext - comp platform progdb' - globalFlags' configFlags'' configExFlags' - installFlags' haddockFlags' testFlags' benchmarkFlags' - targets - - where - -- '--run-tests' implies '--enable-tests'. - maybeForceTests installFlags' configFlags' = - if fromFlagOrDefault False (installRunTests installFlags') - then configFlags' { configTests = toFlag True } - else configFlags' - -testAction :: (BuildFlags, TestFlags) -> [String] -> GlobalFlags - -> IO () -testAction (buildFlags, testFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) - config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (testDistPref testFlags) - let buildFlags' = buildFlags - { buildVerbosity = testVerbosity testFlags } - checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> - if fromFlagOrDefault False (configTests configFlags) - then pure (mempty, flags) - else do - info verbosity "reconfiguring to enable tests" - let flags' = ( configFlags { configTests = toFlag True } - , configExFlags - ) - pure (Any True, flags') - - _ <- - reconfigure configureAction - verbosity distPref (buildNumJobs buildFlags') - checkFlags [] globalFlags config - nixShell verbosity distPref globalFlags config $ do - let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } - testFlags' = testFlags { testDistPref = toFlag distPref } - - -- The package was just configured, so the LBI must be available. - names <- componentNamesFromLBI verbosity distPref "test suites" - (\c -> case c of { LBI.CTest{} -> True; _ -> False }) - let extraArgs' - | null extraArgs = case names of - ComponentNamesUnknown -> [] - ComponentNames names' -> [ Make.unUnqualComponentName name - | LBI.CTestName name <- names' ] - | otherwise = extraArgs - - build verbosity config distPref buildFlags' extraArgs' - setupWrapper verbosity setupOptions Nothing Cabal.testCommand (const testFlags') (const extraArgs') - -data ComponentNames = ComponentNamesUnknown - | ComponentNames [LBI.ComponentName] - --- | Return the names of all buildable components matching a given predicate. -componentNamesFromLBI :: Verbosity -> FilePath -> String - -> (LBI.Component -> Bool) - -> IO ComponentNames -componentNamesFromLBI verbosity distPref targetsDescr compPred = do - eLBI <- tryGetPersistBuildConfig distPref - case eLBI of - Left err -> case err of - -- Note: the build config could have been generated by a custom setup - -- script built against a different Cabal version, so it's crucial that - -- we ignore the bad version error here. - ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown - _ -> die' verbosity (show err) - Right lbi -> do - let pkgDescr = LBI.localPkgDescr lbi - names = map LBI.componentName - . filter (buildable . LBI.componentBuildInfo) - . filter compPred $ - LBI.pkgComponents pkgDescr - if null names - then do notice verbosity $ "Package has no buildable " - ++ targetsDescr ++ "." - exitSuccess -- See #3215. - - else return $! (ComponentNames names) - -benchmarkAction :: (BuildFlags, BenchmarkFlags) - -> [String] -> GlobalFlags - -> IO () -benchmarkAction - (buildFlags, benchmarkFlags) - extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal - (buildVerbosity buildFlags) - - config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags) - let buildFlags' = buildFlags - { buildVerbosity = benchmarkVerbosity benchmarkFlags } - - let checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> - if fromFlagOrDefault False (configBenchmarks configFlags) - then pure (mempty, flags) - else do - info verbosity "reconfiguring to enable benchmarks" - let flags' = ( configFlags { configBenchmarks = toFlag True } - , configExFlags - ) - pure (Any True, flags') - - config' <- - reconfigure configureAction - verbosity distPref (buildNumJobs buildFlags') - checkFlags [] globalFlags config - nixShell verbosity distPref globalFlags config $ do - let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } - benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref } - - -- The package was just configured, so the LBI must be available. - names <- componentNamesFromLBI verbosity distPref "benchmarks" - (\c -> case c of { LBI.CBench{} -> True; _ -> False; }) - let extraArgs' - | null extraArgs = case names of - ComponentNamesUnknown -> [] - ComponentNames names' -> [ Make.unUnqualComponentName name - | LBI.CBenchName name <- names'] - | otherwise = extraArgs - - build verbosity config' distPref buildFlags' extraArgs' - setupWrapper verbosity setupOptions Nothing Cabal.benchmarkCommand (const benchmarkFlags') (const extraArgs') - -haddockAction :: HaddockFlags -> [String] -> Action -haddockAction haddockFlags extraArgs globalFlags = do - let verbosity = fromFlag (haddockVerbosity haddockFlags) - config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (haddockDistPref haddockFlags) - config' <- - reconfigure configureAction - verbosity distPref NoFlag - mempty [] globalFlags config - nixShell verbosity distPref globalFlags config $ do - let haddockFlags' = defaultHaddockFlags `mappend` - savedHaddockFlags config' `mappend` - haddockFlags { haddockDistPref = toFlag distPref } - setupScriptOptions = defaultSetupScriptOptions - { useDistPref = distPref } - setupWrapper verbosity setupScriptOptions Nothing - haddockCommand (const haddockFlags') (const extraArgs) - when (haddockForHackage haddockFlags == Flag ForHackage) $ do - pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) - let dest = distPref name <.> "tar.gz" - name = display (packageId pkg) ++ "-docs" - docDir = distPref "doc" "html" - createTarGzFile dest docDir name - notice verbosity $ "Documentation tarball created: " ++ dest - -cleanAction :: CleanFlags -> [String] -> Action -cleanAction cleanFlags extraArgs globalFlags = do - load <- try (loadConfigOrSandboxConfig verbosity globalFlags) - let config = either (\(SomeException _) -> mempty) id load - distPref <- findSavedDistPref config (cleanDistPref cleanFlags) - let setupScriptOptions = defaultSetupScriptOptions - { useDistPref = distPref - , useWin32CleanHack = True - } - cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref } - setupWrapper verbosity setupScriptOptions Nothing - cleanCommand (const cleanFlags') (const extraArgs) - where - verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags) - -listAction :: ListFlags -> [String] -> Action -listAction listFlags extraArgs globalFlags = do - let verbosity = fromFlag (listVerbosity listFlags) - config <- loadConfigOrSandboxConfig verbosity globalFlags - let configFlags' = savedConfigureFlags config - configFlags = configFlags' - { configPackageDBs = configPackageDBs configFlags' - `mappend` listPackageDBs listFlags - , configHcPath = listHcPath listFlags - } - globalFlags' = savedGlobalFlags config `mappend` globalFlags - compProgdb <- if listNeedsCompiler listFlags - then do - (comp, _, progdb) <- configCompilerAux' configFlags - return (Just (comp, progdb)) - else return Nothing - withRepoContext verbosity globalFlags' $ \repoContext -> - List.list verbosity - (configPackageDB' configFlags) - repoContext - compProgdb - listFlags - extraArgs - -infoAction :: InfoFlags -> [String] -> Action -infoAction infoFlags extraArgs globalFlags = do - let verbosity = fromFlag (infoVerbosity infoFlags) - targets <- readUserTargets verbosity extraArgs - config <- loadConfigOrSandboxConfig verbosity globalFlags - let configFlags' = savedConfigureFlags config - configFlags = configFlags' { - configPackageDBs = configPackageDBs configFlags' - `mappend` infoPackageDBs infoFlags - } - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, _, progdb) <- configCompilerAuxEx configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - List.info verbosity - (configPackageDB' configFlags) - repoContext - comp - progdb - globalFlags' - infoFlags - targets - -fetchAction :: FetchFlags -> [String] -> Action -fetchAction fetchFlags extraArgs globalFlags = do - let verbosity = fromFlag (fetchVerbosity fetchFlags) - targets <- readUserTargets verbosity extraArgs - config <- loadConfig verbosity (globalConfigFile globalFlags) - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAux' configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - fetch verbosity - (configPackageDB' configFlags) - repoContext - comp platform progdb globalFlags' fetchFlags - targets - -freezeAction :: FreezeFlags -> [String] -> Action -freezeAction freezeFlags _extraArgs globalFlags = do - let verbosity = fromFlag (freezeVerbosity freezeFlags) - config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config NoFlag - nixShell verbosity distPref globalFlags config $ do - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAux' configFlags - - withRepoContext verbosity globalFlags' $ \repoContext -> - freeze verbosity - (configPackageDB' configFlags) - repoContext - comp platform progdb - globalFlags' freezeFlags - -genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () -genBoundsAction freezeFlags _extraArgs globalFlags = do - let verbosity = fromFlag (freezeVerbosity freezeFlags) - config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config NoFlag - nixShell verbosity distPref globalFlags config $ do - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAux' configFlags - - withRepoContext verbosity globalFlags' $ \repoContext -> - genBounds verbosity - (configPackageDB' configFlags) - repoContext - comp platform progdb - globalFlags' freezeFlags - -uploadAction :: UploadFlags -> [String] -> Action -uploadAction uploadFlags extraArgs globalFlags = do - config <- loadConfig verbosity (globalConfigFile globalFlags) - let uploadFlags' = savedUploadFlags config `mappend` uploadFlags - globalFlags' = savedGlobalFlags config `mappend` globalFlags - tarfiles = extraArgs - when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $ - die' verbosity "the 'upload' command expects at least one .tar.gz archive." - checkTarFiles extraArgs - maybe_password <- - case uploadPasswordCmd uploadFlags' - of Flag (xs:xss) -> Just . Password <$> - getProgramInvocationOutput verbosity - (simpleProgramInvocation xs xss) - _ -> pure $ flagToMaybe $ uploadPassword uploadFlags' - withRepoContext verbosity globalFlags' $ \repoContext -> do - if fromFlag (uploadDoc uploadFlags') - then do - when (length tarfiles > 1) $ - die' verbosity $ "the 'upload' command can only upload documentation " - ++ "for one package at a time." - tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles - Upload.uploadDoc verbosity - repoContext - (flagToMaybe $ uploadUsername uploadFlags') - maybe_password - (fromFlag (uploadCandidate uploadFlags')) - tarfile - else do - Upload.upload verbosity - repoContext - (flagToMaybe $ uploadUsername uploadFlags') - maybe_password - (fromFlag (uploadCandidate uploadFlags')) - tarfiles - where - verbosity = fromFlag (uploadVerbosity uploadFlags) - checkTarFiles tarfiles - | not (null otherFiles) - = die' verbosity $ "the 'upload' command expects only .tar.gz archives: " - ++ intercalate ", " otherFiles - | otherwise = sequence_ - [ do exists <- doesFileExist tarfile - unless exists $ die' verbosity $ "file not found: " ++ tarfile - | tarfile <- tarfiles ] - - where otherFiles = filter (not . isTarGzFile) tarfiles - isTarGzFile file = case splitExtension file of - (file', ".gz") -> takeExtension file' == ".tar" - _ -> False - generateDocTarball config = do - notice verbosity $ - "No documentation tarball specified. " - ++ "Building a documentation tarball with default settings...\n" - ++ "If you need to customise Haddock options, " - ++ "run 'haddock --for-hackage' first " - ++ "to generate a documentation tarball." - haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage }) - [] globalFlags - distPref <- findSavedDistPref config NoFlag - pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) - return $ distPref display (packageId pkg) ++ "-docs" <.> "tar.gz" - -checkAction :: Flag Verbosity -> [String] -> Action -checkAction verbosityFlag extraArgs _globalFlags = do - let verbosity = fromFlag verbosityFlag - unless (null extraArgs) $ - die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs - allOk <- Check.check (fromFlag verbosityFlag) - unless allOk exitFailure - -formatAction :: Flag Verbosity -> [String] -> Action -formatAction verbosityFlag extraArgs _globalFlags = do - let verbosity = fromFlag verbosityFlag - path <- case extraArgs of - [] -> do cwd <- getCurrentDirectory - tryFindPackageDesc verbosity cwd - (p:_) -> return p - pkgDesc <- readGenericPackageDescription verbosity path - -- Uses 'writeFileAtomic' under the hood. - writeGenericPackageDescription path pkgDesc - -reportAction :: ReportFlags -> [String] -> Action -reportAction reportFlags extraArgs globalFlags = do - let verbosity = fromFlag (reportVerbosity reportFlags) - unless (null extraArgs) $ - die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs - config <- loadConfig verbosity (globalConfigFile globalFlags) - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - reportFlags' = savedReportFlags config `mappend` reportFlags - - withRepoContext verbosity globalFlags' $ \repoContext -> - Upload.report verbosity repoContext - (flagToMaybe $ reportUsername reportFlags') - (flagToMaybe $ reportPassword reportFlags') - -runAction :: BuildFlags -> [String] -> Action -runAction buildFlags extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) - config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (buildDistPref buildFlags) - config' <- - reconfigure configureAction - verbosity distPref (buildNumJobs buildFlags) - mempty [] globalFlags config - nixShell verbosity distPref globalFlags config $ do - lbi <- getPersistBuildConfig distPref - (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs - - build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)] - run verbosity lbi exe exeArgs - -getAction :: GetFlags -> [String] -> Action -getAction getFlags extraArgs globalFlags = do - let verbosity = fromFlag (getVerbosity getFlags) - targets <- readUserTargets verbosity extraArgs - config <- loadConfigOrSandboxConfig verbosity globalFlags - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - withRepoContext verbosity (savedGlobalFlags config) $ \repoContext -> - get verbosity - repoContext - globalFlags' - getFlags - targets - -unpackAction :: GetFlags -> [String] -> Action -unpackAction getFlags extraArgs globalFlags = do - getAction getFlags extraArgs globalFlags - -initAction :: InitFlags -> [String] -> Action -initAction initFlags extraArgs globalFlags = do - -- it takes the first value within extraArgs (if there's one) - -- and uses it as the root directory for the new project - case extraArgs of - [] -> initAction' - [projectDir] -> do - createDirectoryIfMissingVerbose verbosity True projectDir - withCurrentDirectory projectDir initAction' - _ -> die' verbosity $ - "'init' only takes a single, optional, extra " ++ - "argument for the project root directory" - where - initAction' = do - confFlags <- loadConfigOrSandboxConfig verbosity globalFlags - -- override with `--with-compiler` from CLI if available - let confFlags' = savedConfigureFlags confFlags `mappend` compFlags - initFlags' = savedInitFlags confFlags `mappend` initFlags - globalFlags' = savedGlobalFlags confFlags `mappend` globalFlags - - (comp, _, progdb) <- configCompilerAux' confFlags' - - withRepoContext verbosity globalFlags' $ \repoContext -> - initCmd verbosity (configPackageDB' confFlags') - repoContext comp progdb initFlags' - - verbosity = fromFlag (initVerbosity initFlags) - compFlags = mempty { configHcPath = initHcPath initFlags } - -userConfigAction :: UserConfigFlags -> [String] -> Action -userConfigAction ucflags extraArgs globalFlags = do - let verbosity = fromFlag (userConfigVerbosity ucflags) - frc = fromFlag (userConfigForce ucflags) - extraLines = fromFlag (userConfigAppendLines ucflags) - case extraArgs of - ("init":_) -> do - path <- configFile - fileExists <- doesFileExist path - if (not fileExists || (fileExists && frc)) - then void $ createDefaultConfigFile verbosity extraLines path - else die' verbosity $ path ++ " already exists." - ("diff":_) -> traverse_ putStrLn =<< userConfigDiff verbosity globalFlags extraLines - ("update":_) -> userConfigUpdate verbosity globalFlags extraLines - -- Error handling. - [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')" - _ -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs - where configFile = getConfigFilePath (globalConfigFile globalFlags) - --- | Used as an entry point when cabal-install needs to invoke itself --- as a setup script. This can happen e.g. when doing parallel builds. --- -actAsSetupAction :: ActAsSetupFlags -> [String] -> Action -actAsSetupAction actAsSetupFlags args _globalFlags = - let bt = fromFlag (actAsSetupBuildType actAsSetupFlags) - in case bt of - Simple -> Simple.defaultMainArgs args - Configure -> Simple.defaultMainWithHooksArgs - Simple.autoconfUserHooks args - Make -> Make.defaultMainArgs args - Custom -> error "actAsSetupAction Custom" - -manpageAction :: [CommandSpec action] -> ManpageFlags -> [String] -> Action -manpageAction commands flags extraArgs _ = do - let verbosity = fromFlag (manpageVerbosity flags) - unless (null extraArgs) $ - die' verbosity $ "'man' doesn't take any extra arguments: " ++ unwords extraArgs - pname <- getProgName - let cabalCmd = if takeExtension pname == ".exe" - then dropExtension pname - else pname - manpageCmd cabalCmd commands flags +module Main (main) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import System.Environment (getArgs) + +import qualified Distribution.Client.Main as Client + +main :: IO () +main = getArgs >>= Client.main diff --git a/src/Distribution/Client/CmdInstall.hs b/src/Distribution/Client/CmdInstall.hs --- a/src/Distribution/Client/CmdInstall.hs +++ b/src/Distribution/Client/CmdInstall.hs @@ -106,7 +106,7 @@ ( configCompilerEx ) import Distribution.Simple.Compiler ( Compiler(..), CompilerId(..), CompilerFlavor(..) - , PackageDBStack ) + , PackageDBStack, PackageDB(..) ) import Distribution.Simple.GHC ( ghcPlatformAndVersionString, getGhcAppDir , GhcImplInfo(..), getImplInfo @@ -123,11 +123,13 @@ import Distribution.Simple.Utils ( wrapText, die', notice, warn , withTempDirectory, createDirectoryIfMissingVerbose - , ordNub ) + , ordNub, safeHead ) import Distribution.Utils.Generic ( writeFileAtomic ) import qualified Data.ByteString.Lazy.Char8 as BS +import Data.Ord + ( Down(..) ) import qualified Data.Map as Map import qualified Data.Set as S import qualified Data.List.NonEmpty as NE @@ -424,7 +426,7 @@ unless dryRun $ if installLibs then installLibraries verbosity - buildCtx compiler packageDbs envFile nonGlobalEnvEntries' + buildCtx installedIndex compiler packageDbs envFile nonGlobalEnvEntries' else installExes verbosity baseCtx buildCtx platform compiler configFlags clientInstallFlags where @@ -687,20 +689,31 @@ installLibraries :: Verbosity -> ProjectBuildContext + -> PI.PackageIndex InstalledPackageInfo -> Compiler -> PackageDBStack -> FilePath -- ^ Environment file -> [GhcEnvironmentFileEntry] -> IO () -installLibraries verbosity buildCtx compiler - packageDbs envFile envEntries = do +installLibraries verbosity buildCtx installedIndex compiler + packageDbs' envFile envEntries = do if supportsPkgEnvFiles $ getImplInfo compiler then do + let validDb (SpecificPackageDB fp) = doesPathExist fp + validDb _ = pure True + -- if a user "installs" a global package and no existing cabal db exists, none will be created. + -- this ensures we don't add the "phantom" path to the file. + packageDbs <- filterM validDb packageDbs' let + getLatest = (=<<) (maybeToList . safeHead . snd) . take 1 . sortBy (comparing (Down . fst)) + . PI.lookupPackageName installedIndex + globalLatest = concat (getLatest <$> globalPackages) + globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest baseEntries = GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs pkgEntries = ordNub $ - envEntries + globalEntries + ++ envEntries ++ entriesForLibraryComponents (targetsMap buildCtx) contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries) createDirectoryIfMissing True (takeDirectory envFile) @@ -710,6 +723,12 @@ "The current compiler doesn't support safely installing libraries, " ++ "so only executables will be available. (Library installation is " ++ "supported on GHC 8.0+ only)" + +-- See ticket #8894. This is safe to include any nonreinstallable boot pkg, +-- but the particular package users will always expect to be in scope without specific installation +-- is base, so that they can access prelude, regardles of if they specifically asked for it. +globalPackages :: [PackageName] +globalPackages = mkPackageName <$> [ "base" ] warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO () warnIfNoExes verbosity buildCtx = diff --git a/src/Distribution/Client/CmdListBin.hs b/src/Distribution/Client/CmdListBin.hs --- a/src/Distribution/Client/CmdListBin.hs +++ b/src/Distribution/Client/CmdListBin.hs @@ -28,7 +28,9 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning.Types import Distribution.Client.ScriptUtils - (AcceptNoTargets(..), TargetContext(..), updateContextAndWriteProjectFile, withContextAndSelectors) + ( AcceptNoTargets(..), TargetContext(..) + , updateContextAndWriteProjectFile, withContextAndSelectors + , movedExePath ) import Distribution.Client.Setup (GlobalFlags (..)) import Distribution.Client.TargetProblem (TargetProblem (..)) import Distribution.Simple.BuildPaths (dllExtension, exeExtension) @@ -170,7 +172,7 @@ bin_file c = case c of CD.ComponentExe s - | s == selectedComponent -> [bin_file' s] + | s == selectedComponent -> [moved_bin_file s] CD.ComponentTest s | s == selectedComponent -> [bin_file' s] CD.ComponentBench s @@ -193,6 +195,8 @@ if elabBuildStyle elab == BuildInplaceOnly then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat + + moved_bin_file s = fromMaybe (bin_file' s) (movedExePath selectedComponent distDirLayout elaboratedSharedConfig elab) ------------------------------------------------------------------------------- -- Target Problem: the very similar to CmdRun diff --git a/src/Distribution/Client/CmdRun.hs b/src/Distribution/Client/CmdRun.hs --- a/src/Distribution/Client/CmdRun.hs +++ b/src/Distribution/Client/CmdRun.hs @@ -22,49 +22,51 @@ import Prelude () import Distribution.Client.Compat.Prelude hiding (toList) -import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages ( renderTargetSelector, showTargetSelector, renderTargetProblem, renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs, targetSelectorFilter, renderListCommaAnd, renderListPretty ) -import Distribution.Client.TargetProblem - ( TargetProblem (..) ) - -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( GlobalFlags(..), ConfigFlags(..) ) import Distribution.Client.GlobalFlags ( defaultGlobalFlags ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) -import Distribution.Types.ComponentName - ( componentNameRaw ) -import Distribution.Verbosity - ( normal, silent ) -import Distribution.Simple.Utils - ( wrapText, die', info, notice, safeHead ) +import Distribution.Client.InstallPlan + ( toList, foldPlanPackage ) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage(..) , ElaboratedInstallPlan, binDirectoryFor ) import Distribution.Client.ProjectPlanning.Types ( dataDirsEnvironmentForPlan ) -import Distribution.Client.InstallPlan - ( toList, foldPlanPackage ) -import Distribution.Types.UnqualComponentName - ( UnqualComponentName, unUnqualComponentName ) +import Distribution.Client.ScriptUtils + ( AcceptNoTargets(..), TargetContext(..) + , updateContextAndWriteProjectFile, withContextAndSelectors + , movedExePath ) +import Distribution.Client.Setup + ( GlobalFlags(..), ConfigFlags(..) ) +import Distribution.Client.TargetProblem + ( TargetProblem (..) ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Simple.Flag + ( fromFlagOrDefault ) import Distribution.Simple.Program.Run ( runProgramInvocation, ProgramInvocation(..), emptyProgramInvocation ) +import Distribution.Simple.Utils + ( wrapText, die', info, notice, safeHead ) +import Distribution.Types.ComponentName + ( componentNameRaw ) import Distribution.Types.UnitId ( UnitId ) -import Distribution.Client.ScriptUtils - ( AcceptNoTargets(..), withContextAndSelectors, updateContextAndWriteProjectFile, TargetContext(..) ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName, unUnqualComponentName ) +import Distribution.Verbosity + ( normal, silent ) + import Data.List (group) import qualified Data.Set as Set import System.Directory @@ -216,11 +218,15 @@ ++ exeName ++ ":\n" ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs) - let exePath = binDirectoryFor (distDirLayout baseCtx) - (elaboratedShared buildCtx) - pkg - exeName - exeName + + let defaultExePath = binDirectoryFor + (distDirLayout baseCtx) + (elaboratedShared buildCtx) + pkg + exeName + exeName + exePath = fromMaybe defaultExePath (movedExePath selectedComponent (distDirLayout baseCtx) (elaboratedShared buildCtx) pkg) + let dryRun = buildSettingDryRun (buildSettings baseCtx) || buildSettingOnlyDownload (buildSettings baseCtx) diff --git a/src/Distribution/Client/CmdUpdate.hs b/src/Distribution/Client/CmdUpdate.hs --- a/src/Distribution/Client/CmdUpdate.hs +++ b/src/Distribution/Client/CmdUpdate.hs @@ -199,10 +199,12 @@ -- NB: always update the timestamp, even if we didn't actually -- download anything writeIndexTimestamp index indexState - ce <- if repoContextIgnoreExpiry repoCtxt - then Just `fmap` getCurrentTime - else return Nothing - updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce + -- typically we get the current time to check expiry against + -- but if the flag is set, we don't. + now' <- case repoContextIgnoreExpiry repoCtxt of + False -> Just <$> getCurrentTime + True -> pure Nothing + updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure now' -- this resolves indexState (which could be HEAD) into a timestamp new_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo let rname = remoteRepoName (repoRemote repo) diff --git a/src/Distribution/Client/Config.hs b/src/Distribution/Client/Config.hs --- a/src/Distribution/Client/Config.hs +++ b/src/Distribution/Client/Config.hs @@ -133,7 +133,7 @@ import Text.PrettyPrint.HughesPJ ( text, Doc ) import System.Directory - ( createDirectoryIfMissing, getHomeDirectory, getXdgDirectory, XdgDirectory(XdgCache, XdgConfig, XdgState), renameFile, getAppUserDataDirectory, doesDirectoryExist ) + ( createDirectoryIfMissing, getHomeDirectory, getXdgDirectory, XdgDirectory(XdgCache, XdgConfig, XdgState), renameFile, getAppUserDataDirectory, doesDirectoryExist, doesFileExist ) import Network.URI ( URI(..), URIAuth(..), parseURI ) import System.FilePath @@ -568,34 +568,50 @@ -- initialSavedConfig :: IO SavedConfig initialSavedConfig = do - cacheDir <- defaultCacheDir - logsDir <- defaultLogsDir - extraPath <- defaultExtraPath + cacheDir <- defaultCacheDir + logsDir <- defaultLogsDir installPath <- defaultInstallPath - return mempty { - savedGlobalFlags = mempty { - globalCacheDir = toFlag cacheDir, - globalRemoteRepos = toNubList [defaultRemoteRepo] - }, - savedConfigureFlags = mempty { - configProgramPathExtra = toNubList extraPath - }, - savedInstallFlags = mempty { - installSummaryFile = toNubList [toPathTemplate (logsDir "build.log")], - installBuildReports= toFlag NoReports, - installNumJobs = toFlag Nothing - }, - savedClientInstallFlags = mempty { - cinstInstalldir = toFlag installPath - } - } + return + mempty + { savedGlobalFlags = + mempty + { globalCacheDir = toFlag cacheDir + , globalRemoteRepos = toNubList [defaultRemoteRepo] + } + , savedInstallFlags = + mempty + { installSummaryFile = toNubList [toPathTemplate (logsDir "build.log")] + , installBuildReports = toFlag NoReports + , installNumJobs = toFlag Nothing + } + , savedClientInstallFlags = + mempty + { cinstInstalldir = toFlag installPath + } + } --- | If @CABAL\_DIR@ is set or @~/.cabal@ exists, return that --- directory. Otherwise returns Nothing. If this function returns --- Nothing, then it implies that we are not using a single directory --- for everything, but instead use XDG paths. Fundamentally, this --- function is used to implement transparent backwards compatibility --- with pre-XDG versions of cabal-install. +-- | Issue a warning if both @$XDG_CONFIG_HOME/cabal/config@ and +-- @~/.cabal@ exists. +warnOnTwoConfigs :: Verbosity -> IO () +warnOnTwoConfigs verbosity = do + defaultDir <- getAppUserDataDirectory "cabal" + dotCabalExists <- doesDirectoryExist defaultDir + xdgCfg <- getXdgDirectory XdgConfig ("cabal" "config") + xdgCfgExists <- doesFileExist xdgCfg + when (dotCabalExists && xdgCfgExists) $ + warn verbosity $ + "Both " <> defaultDir <> + " and " <> xdgCfg <> + " exist - ignoring the former.\n" <> + "It is advisable to remove one of them. In that case, we will use the remaining one by default (unless '$CABAL_DIR' is explicitly set)." + +-- | If @CABAL\_DIR@ is set, return @Just@ its value. Otherwise, if +-- @~/.cabal@ exists and @$XDG_CONFIG_HOME/cabal/config@ does not +-- exist, return @Just "~/.cabal"@. Otherwise, return @Nothing@. If +-- this function returns Nothing, then it implies that we are not +-- using a single directory for everything, but instead use XDG paths. +-- Fundamentally, this function is used to implement transparent +-- backwards compatibility with pre-XDG versions of cabal-install. maybeGetCabalDir :: IO (Maybe FilePath) maybeGetCabalDir = do mDir <- lookupEnv "CABAL_DIR" @@ -604,9 +620,11 @@ Nothing -> do defaultDir <- getAppUserDataDirectory "cabal" dotCabalExists <- doesDirectoryExist defaultDir - return $ if dotCabalExists - then Just defaultDir - else Nothing + xdgCfg <- getXdgDirectory XdgConfig ("cabal" "config") + xdgCfgExists <- doesFileExist xdgCfg + if dotCabalExists && not xdgCfgExists + then return $ Just defaultDir + else return Nothing -- | The default behaviour of cabal-install is to use the XDG -- directory standard. However, if @CABAL_DIR@ is set, we instead use @@ -656,16 +674,6 @@ defaultReportsDir = getDefaultDir XdgCache "reports" -defaultExtraPath :: IO [FilePath] -defaultExtraPath = do - mDir <- maybeGetCabalDir - case mDir of - Just dir -> - return [dir "bin"] - Nothing -> do - dir <- getHomeDirectory - return [dir ".local" "bin"] - defaultInstallPath :: IO FilePath defaultInstallPath = do mDir <- maybeGetCabalDir @@ -737,12 +745,29 @@ -- defaultHackageRemoteRepoKeys :: [String] defaultHackageRemoteRepoKeys = - [ "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0", - "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42", - "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3", - "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d", - "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" - ] + -- Key owners and public keys are provided as a convenience to readers. + -- The canonical source for this mapping data is the hackage-root-keys + -- repository and Hackage's root.json file. + -- + -- Links: + -- * https://github.com/haskell-infra/hackage-root-keys + -- * https://hackage.haskell.org/root.json + -- Please consult root.json on Hackage to map key IDs to public keys, + -- and the hackage-root-keys repository to map public keys to their + -- owners. + [ -- Adam Gundry (uRPdSiL3/MNsk50z6NB55ABo0OrrNDXigtCul4vtzmw=) + "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" + , -- Gershom Bazerman (bYoUXXQ9TtX10UriaMiQtTccuXPGnmldP68djzZ7cLo=) + "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" + , -- John Wiegley (zazm5w480r+zPO6Z0+8fjGuxZtb9pAuoVmQ+VkuCvgU=) + "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" + , -- Norman Ramsey (ZI8di3a9Un0s2RBrt5GwVRvfOXVuywADfXGPZfkiDb0=) + "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" + , -- Mathieu Boespflug (ydN1nGGQ79K1Q0nN+ul+Ln8MxikTB95w0YdGd3v3kmg=) + "be75553f3c7ba1dbe298da81f1d1b05c9d39dd8ed2616c9bddf1525ca8c03e48" + , -- Joachim Breitner (5iUgwqZCWrCJktqMx0bBMIuoIyT4A1RYGozzchRN9rA=) + "d26e46f3b631aae1433b89379a6c68bd417eb5d1c408f0643dcc07757fece522" + ] -- | The required threshold of root key signatures for hackage.haskell.org -- @@ -759,6 +784,7 @@ -- loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig loadConfig verbosity configFileFlag = do + warnOnTwoConfigs verbosity config <- loadRawConfig verbosity configFileFlag extendToEffectiveConfig config @@ -900,7 +926,8 @@ globalInstallDirs <- defaultInstallDirs defaultCompiler False True let conf0 = mempty { savedGlobalFlags = defaultGlobalFlags { - globalRemoteRepos = toNubList [defaultRemoteRepo] + globalRemoteRepos = toNubList [defaultRemoteRepo], + globalNix = mempty }, savedInitFlags = mempty { IT.interactive = toFlag False, diff --git a/src/Distribution/Client/Dependency.hs b/src/Distribution/Client/Dependency.hs --- a/src/Distribution/Client/Dependency.hs +++ b/src/Distribution/Client/Dependency.hs @@ -397,24 +397,50 @@ | Set.notMember (mkPackageName "base") (depResolverTargets params) -- If you change this enumeration, make sure to update the list in -- "Distribution.Solver.Modular.Solver" as well - , pkgname <- [ mkPackageName "base" - , mkPackageName "ghc-bignum" - , mkPackageName "ghc-prim" - , mkPackageName "ghc-boot" - , mkPackageName "ghc" - , mkPackageName "ghci" - , mkPackageName "integer-gmp" - , mkPackageName "integer-simple" - , mkPackageName "template-haskell" - ] + , pkgname <- nonUpgradeablePackages , isInstalled pkgname ] isInstalled = not . null . InstalledPackageIndex.lookupPackageName (depResolverInstalledPkgIndex params) -addSourcePackages :: [UnresolvedSourcePackage] - -> DepResolverParams -> DepResolverParams +-- | The set of non-reinstallable packages includes those which cannot be +-- rebuilt using a GHC installation and Hackage-published source distribution. +-- There are a few reasons why this might be true: +-- +-- * the package overrides its unit ID (e.g. with ghc's @-this-unit-id@ flag), +-- which can result in multiple indistinguishable packages (having potentially +-- different ABIs) with the same unit ID. +-- +-- * the package contains definitions of wired-in declarations which tie +-- it to a particular compiler (e.g. we can't build link against +-- @base-4.18.0.0@ using GHC 9.6.1). +-- +-- * the package does not have a complete (that is, buildable) source distribution. +-- For instance, some packages provided by GHC rely on files outside of the +-- source tree generated by GHC's build system. +-- +-- Note: the list of non-upgradable/non-installable packages used to be +-- respectively in this module and in `Distribution.Solver.Modular.Solver`. +-- Since they were kept synced, they are now combined in the following list. +-- +-- See: https://github.com/haskell/cabal/issues/8581 and +-- https://github.com/haskell/cabal/issues/9064. +nonUpgradeablePackages :: [PackageName] +nonUpgradeablePackages = + [ mkPackageName "base" + , mkPackageName "ghc-bignum" + , mkPackageName "ghc-prim" + , mkPackageName "ghc" + , mkPackageName "integer-gmp" + , mkPackageName "integer-simple" + , mkPackageName "template-haskell" + ] + +addSourcePackages + :: [UnresolvedSourcePackage] + -> DepResolverParams + -> DepResolverParams addSourcePackages pkgs params = params { depResolverSourcePkgIndex = diff --git a/src/Distribution/Client/HashValue.hs b/src/Distribution/Client/HashValue.hs --- a/src/Distribution/Client/HashValue.hs +++ b/src/Distribution/Client/HashValue.hs @@ -6,6 +6,7 @@ hashValue, truncateHash, showHashValue, + showHashValueBase64, readFileHashValue, hashFromTUF, ) where @@ -17,6 +18,7 @@ import qualified Crypto.Hash.SHA256 as SHA256 import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS @@ -54,6 +56,9 @@ showHashValue :: HashValue -> String showHashValue (HashValue digest) = BS.unpack (Base16.encode digest) + +showHashValueBase64 :: HashValue -> String +showHashValueBase64 (HashValue digest) = BS.unpack (Base64.encode digest) -- | Hash the content of a file. Uses SHA256. -- diff --git a/src/Distribution/Client/Init/Interactive/Command.hs b/src/Distribution/Client/Init/Interactive/Command.hs --- a/src/Distribution/Client/Init/Interactive/Command.hs +++ b/src/Distribution/Client/Init/Interactive/Command.hs @@ -356,14 +356,10 @@ else fmap prettyShow knownLicenses authorPrompt :: Interactive m => InitFlags -> m String -authorPrompt flags = getAuthor flags $ do - name <- guessAuthorName - promptStr "Author name" (DefaultPrompt name) +authorPrompt flags = getAuthor flags $ guessAuthorName >>= promptOrDefault "Author name" emailPrompt :: Interactive m => InitFlags -> m String -emailPrompt flags = getEmail flags $ do - email' <- guessAuthorEmail - promptStr "Maintainer email" (DefaultPrompt email') +emailPrompt flags = getEmail flags $ guessAuthorEmail >>= promptOrDefault "Maintainer email" homepagePrompt :: Interactive m => InitFlags -> m String homepagePrompt flags = getHomepage flags $ @@ -468,3 +464,6 @@ True return [dir] + +promptOrDefault :: Interactive m => String -> Maybe String -> m String +promptOrDefault s = maybe (promptStr s MandatoryPrompt) (promptStr s . DefaultPrompt) diff --git a/src/Distribution/Client/Init/NonInteractive/Command.hs b/src/Distribution/Client/Init/NonInteractive/Command.hs --- a/src/Distribution/Client/Init/NonInteractive/Command.hs +++ b/src/Distribution/Client/Init/NonInteractive/Command.hs @@ -274,14 +274,16 @@ licenseHeuristics flags = getLicense flags $ guessLicense flags -- | The author's name. Prompt, or try to guess from an existing --- darcs repo. +-- git repo. authorHeuristics :: Interactive m => InitFlags -> m String -authorHeuristics flags = getAuthor flags guessAuthorEmail +authorHeuristics flags = guessAuthorName >>= + maybe (getAuthor flags $ return "Unknown") (getAuthor flags . return) -- | The author's email. Prompt, or try to guess from an existing --- darcs repo. +-- git repo. emailHeuristics :: Interactive m => InitFlags -> m String -emailHeuristics flags = getEmail flags guessAuthorName +emailHeuristics flags = guessAuthorEmail >>= + maybe (getEmail flags $ return "Unknown") (getEmail flags . return) -- | Prompt for a homepage URL for the package. homepageHeuristics :: Interactive m => InitFlags -> m String diff --git a/src/Distribution/Client/Init/NonInteractive/Heuristics.hs b/src/Distribution/Client/Init/NonInteractive/Heuristics.hs --- a/src/Distribution/Client/Init/NonInteractive/Heuristics.hs +++ b/src/Distribution/Client/Init/NonInteractive/Heuristics.hs @@ -151,18 +151,23 @@ True -> ["src"] -- | Guess author and email using git configuration options. -guessAuthorName :: Interactive m => m String +guessAuthorName :: Interactive m => m (Maybe String) guessAuthorName = guessGitInfo "user.name" -guessAuthorEmail :: Interactive m => m String +guessAuthorEmail :: Interactive m => m (Maybe String) guessAuthorEmail = guessGitInfo "user.email" -guessGitInfo :: Interactive m => String -> m String +guessGitInfo :: Interactive m => String -> m (Maybe String) guessGitInfo target = do - info <- readProcessWithExitCode "git" ["config", "--local", target] "" - if null $ snd' info - then trim . snd' <$> readProcessWithExitCode "git" ["config", "--global", target] "" - else return . trim $ snd' info + localInfo <- readProcessWithExitCode "git" ["config", "--local", target] "" + if null $ snd' localInfo + then do + globalInfo <- readProcessWithExitCode "git" ["config", "--global", target] "" + case fst' globalInfo of + ExitSuccess -> return $ Just (trim $ snd' globalInfo) + _ -> return Nothing + else return $ Just (trim $ snd' localInfo) where + fst' (x, _, _) = x snd' (_, x, _) = x diff --git a/src/Distribution/Client/Main.hs b/src/Distribution/Client/Main.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Main.hs @@ -0,0 +1,1013 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Entry point to the default cabal-install front-end. +-- +-- @since 3.10.0.0 +----------------------------------------------------------------------------- + +module Distribution.Client.Main (main) where + +import Distribution.Client.Setup + ( GlobalFlags(..), globalCommand, withRepoContext + , ConfigFlags(..) + , ConfigExFlags(..), defaultConfigExFlags, configureExCommand + , reconfigureCommand + , configCompilerAux', configPackageDB' + , BuildFlags(..) + , buildCommand, replCommand, testCommand, benchmarkCommand + , InstallFlags(..), defaultInstallFlags + , installCommand + , FetchFlags(..), fetchCommand + , FreezeFlags(..), freezeCommand + , genBoundsCommand + , GetFlags(..), getCommand, unpackCommand + , checkCommand + , formatCommand + , ListFlags(..), listCommand, listNeedsCompiler + , InfoFlags(..), infoCommand + , UploadFlags(..), uploadCommand + , ReportFlags(..), reportCommand + , runCommand + , InitFlags(initVerbosity, initHcPath), initCommand + , ActAsSetupFlags(..), actAsSetupCommand + , UserConfigFlags(..), userConfigCommand + , reportCommand + , manpageCommand + , haddockCommand + , cleanCommand + , copyCommand + , registerCommand + ) +import Distribution.Simple.Setup + ( HaddockTarget(..) + , HaddockFlags(..), defaultHaddockFlags + , HscolourFlags(..), hscolourCommand + , ReplFlags(..) + , CopyFlags(..) + , RegisterFlags(..) + , CleanFlags(..) + , TestFlags(..), BenchmarkFlags(..) + , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag + , configAbsolutePaths + ) + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (get) + +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import Distribution.Client.Config + ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff + , userConfigUpdate, createDefaultConfigFile, getConfigFilePath ) +import Distribution.Client.Targets + ( readUserTargets ) +import qualified Distribution.Client.List as List + ( list, info ) + +import qualified Distribution.Client.CmdConfigure as CmdConfigure +import qualified Distribution.Client.CmdUpdate as CmdUpdate +import qualified Distribution.Client.CmdBuild as CmdBuild +import qualified Distribution.Client.CmdRepl as CmdRepl +import qualified Distribution.Client.CmdFreeze as CmdFreeze +import qualified Distribution.Client.CmdHaddock as CmdHaddock +import qualified Distribution.Client.CmdHaddockProject as CmdHaddockProject +import qualified Distribution.Client.CmdInstall as CmdInstall +import qualified Distribution.Client.CmdRun as CmdRun +import qualified Distribution.Client.CmdTest as CmdTest +import qualified Distribution.Client.CmdBench as CmdBench +import qualified Distribution.Client.CmdExec as CmdExec +import qualified Distribution.Client.CmdClean as CmdClean +import qualified Distribution.Client.CmdSdist as CmdSdist +import qualified Distribution.Client.CmdListBin as CmdListBin +import qualified Distribution.Client.CmdOutdated as CmdOutdated +import Distribution.Client.CmdLegacy + +import Distribution.Client.Install (install) +import Distribution.Client.Configure (configure, writeConfigFlags) +import Distribution.Client.Fetch (fetch) +import Distribution.Client.Freeze (freeze) +import Distribution.Client.GenBounds (genBounds) +import Distribution.Client.Check as Check (check) +--import Distribution.Client.Clean (clean) +import qualified Distribution.Client.Upload as Upload +import Distribution.Client.Run (run, splitRunArgs) +import Distribution.Client.Get (get) +import Distribution.Client.Reconfigure (Check(..), reconfigure) +import Distribution.Client.Nix (nixInstantiate + ,nixShell + ) +import Distribution.Client.Sandbox (loadConfigOrSandboxConfig + ,findSavedDistPref + ,updateInstallDirs) +import Distribution.Client.Tar (createTarGzFile) +import Distribution.Client.Types.Credentials (Password (..)) +import Distribution.Client.Init (initCmd) +import Distribution.Client.Manpage (manpageCmd) +import Distribution.Client.ManpageFlags (ManpageFlags (..)) +import Distribution.Client.Utils + ( determineNumJobs, relaxEncodingErrors ) +import Distribution.Client.Signal + ( installTerminationHandler ) +import Distribution.Client.Version + ( cabalInstallVersion ) + +import Distribution.Package (packageId) +import Distribution.PackageDescription + ( BuildType(..), Executable(..), buildable ) + +import Distribution.PackageDescription.PrettyPrint + ( writeGenericPackageDescription ) +import qualified Distribution.Simple as Simple +import qualified Distribution.Make as Make +import qualified Distribution.Types.UnqualComponentName as Make +import Distribution.Simple.Build + ( startInterpreter ) +import Distribution.Simple.Command + ( CommandParse(..), CommandUI(..), Command, CommandSpec(..) + , CommandType(..), commandsRun, commandAddAction, hiddenCommand + , commandFromSpec, commandShowOptions ) +import Distribution.Simple.Compiler (PackageDBStack) +import Distribution.Simple.Configure + ( configCompilerAuxEx, ConfigStateFileError(..) + , getPersistBuildConfig, interpretPackageDbFlags + , tryGetPersistBuildConfig ) +import qualified Distribution.Simple.LocalBuildInfo as LBI +import Distribution.Simple.PackageDescription ( readGenericPackageDescription ) +import Distribution.Simple.Program (defaultProgramDb + ,configureAllKnownPrograms + ,simpleProgramInvocation + ,getProgramInvocationOutput) +import Distribution.Simple.Program.Db (reconfigurePrograms) +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Utils + ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler + , findPackageDesc, tryFindPackageDesc, createDirectoryIfMissingVerbose ) +import Distribution.Text + ( display ) +import Distribution.Verbosity as Verbosity + ( normal ) +import Distribution.Version + ( Version, mkVersion, orLaterVersion ) + +import Distribution.Compat.ResponseFile +import System.Environment (getProgName) +import System.FilePath ( dropExtension, splitExtension + , takeExtension, (), (<.>) ) +import System.IO ( BufferMode(LineBuffering), hSetBuffering + , hPutStrLn, stderr, stdout ) +import System.Directory ( doesFileExist, getCurrentDirectory + , withCurrentDirectory) +import Data.Monoid (Any(..)) +import Control.Exception (AssertionFailed, assert, try) + + +-- | Entry point +-- +main :: [String] -> IO () +main args = do + installTerminationHandler + -- Enable line buffering so that we can get fast feedback even when piped. + -- This is especially important for CI and build systems. + hSetBuffering stdout LineBuffering + + -- If the locale encoding for CLI doesn't support all Unicode characters, + -- printing to it may fail unless we relax the handling of encoding errors + -- when writing to stderr and stdout. + relaxEncodingErrors stdout + relaxEncodingErrors stderr + let (args0, args1) = break (== "--") args + + mainWorker =<< (++ args1) <$> expandResponse args0 + +-- | Check whether assertions are enabled and print a warning in that case. +warnIfAssertionsAreEnabled :: IO () +warnIfAssertionsAreEnabled = + assert False (return ()) `catch` + (\(_e :: AssertionFailed) -> hPutStrLn stderr assertionsEnabledMsg) + -- Andreas, 2022-12-30, issue #8654: + -- The verbosity machinery is not in place at this point (option -v not parsed), + -- so instead of using function @warn@, we print straight to stderr. + where + assertionsEnabledMsg = + "Warning: this is a debug build of cabal-install with assertions enabled." + +mainWorker :: [String] -> IO () +mainWorker args = do + topHandler $ + case commandsRun (globalCommand commands) commands args of + CommandHelp help -> printGlobalHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (globalFlags, commandParse) -> + case commandParse of + _ | fromFlagOrDefault False (globalVersion globalFlags) + -> printVersion + | fromFlagOrDefault False (globalNumericVersion globalFlags) + -> printNumericVersion + CommandHelp help -> printCommandHelp help + CommandList opts -> printOptionsList opts + + CommandErrors errs -> do + -- Check whether cabal is called from a script, like #!/path/to/cabal. + case args of + [] -> printErrors errs + script : scriptArgs -> CmdRun.validScript script >>= \case + False -> printErrors errs + True -> do + -- In main operation (not help, version etc.) print warning if assertions are on. + warnIfAssertionsAreEnabled + CmdRun.handleShebang script scriptArgs + + CommandReadyToGo action -> do + -- In main operation (not help, version etc.) print warning if assertions are on. + warnIfAssertionsAreEnabled + action globalFlags + + where + printCommandHelp help = do + pname <- getProgName + putStr (help pname) + printGlobalHelp help = do + pname <- getProgName + configFile <- defaultConfigFile + putStr (help pname) + putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" + ++ " " ++ configFile ++ "\n" + exists <- doesFileExist configFile + unless exists $ + putStrLn $ "This file will be generated with sensible " + ++ "defaults if you run 'cabal update'." + printOptionsList = putStr . unlines + printErrors errs = dieNoVerbosity $ intercalate "\n" errs + printNumericVersion = putStrLn $ display cabalInstallVersion + printVersion = putStrLn $ "cabal-install version " + ++ display cabalInstallVersion + ++ "\ncompiled using version " + ++ display cabalVersion + ++ " of the Cabal library " + + commands = map commandFromSpec commandSpecs + commandSpecs = + [ regularCmd listCommand listAction + , regularCmd infoCommand infoAction + , regularCmd fetchCommand fetchAction + , regularCmd getCommand getAction + , regularCmd unpackCommand unpackAction + , regularCmd checkCommand checkAction + , regularCmd uploadCommand uploadAction + , regularCmd reportCommand reportAction + , regularCmd initCommand initAction + , regularCmd userConfigCommand userConfigAction + , regularCmd genBoundsCommand genBoundsAction + , regularCmd CmdOutdated.outdatedCommand CmdOutdated.outdatedAction + , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref + , hiddenCmd formatCommand formatAction + , hiddenCmd actAsSetupCommand actAsSetupAction + , hiddenCmd manpageCommand (manpageAction commandSpecs) + , regularCmd CmdListBin.listbinCommand CmdListBin.listbinAction + + ] ++ concat + [ newCmd CmdConfigure.configureCommand CmdConfigure.configureAction + , newCmd CmdUpdate.updateCommand CmdUpdate.updateAction + , newCmd CmdBuild.buildCommand CmdBuild.buildAction + , newCmd CmdRepl.replCommand CmdRepl.replAction + , newCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction + , newCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction + , newCmd CmdHaddockProject.haddockProjectCommand + CmdHaddockProject.haddockProjectAction + , newCmd CmdInstall.installCommand CmdInstall.installAction + , newCmd CmdRun.runCommand CmdRun.runAction + , newCmd CmdTest.testCommand CmdTest.testAction + , newCmd CmdBench.benchCommand CmdBench.benchAction + , newCmd CmdExec.execCommand CmdExec.execAction + , newCmd CmdClean.cleanCommand CmdClean.cleanAction + , newCmd CmdSdist.sdistCommand CmdSdist.sdistAction + + , legacyCmd configureExCommand configureAction + , legacyCmd buildCommand buildAction + , legacyCmd replCommand replAction + , legacyCmd freezeCommand freezeAction + , legacyCmd haddockCommand haddockAction + , legacyCmd installCommand installAction + , legacyCmd runCommand runAction + , legacyCmd testCommand testAction + , legacyCmd benchmarkCommand benchmarkAction + , legacyCmd cleanCommand cleanAction + , legacyWrapperCmd copyCommand copyVerbosity copyDistPref + , legacyWrapperCmd registerCommand regVerbosity regDistPref + , legacyCmd reconfigureCommand reconfigureAction + ] + +type Action = GlobalFlags -> IO () + +-- Duplicated in Distribution.Client.CmdLegacy. Any changes must be +-- reflected there, as well. +regularCmd :: CommandUI flags -> (flags -> [String] -> action) + -> CommandSpec action +regularCmd ui action = + CommandSpec ui ((flip commandAddAction) action) NormalCommand + +hiddenCmd :: CommandUI flags -> (flags -> [String] -> action) + -> CommandSpec action +hiddenCmd ui action = + CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action)) + HiddenCommand + +wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) + -> (flags -> Flag String) -> CommandSpec Action +wrapperCmd ui verbosity distPref = + CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand + +wrapperAction :: Monoid flags + => CommandUI flags + -> (flags -> Flag Verbosity) + -> (flags -> Flag String) + -> Command Action +wrapperAction command verbosityFlag distPrefFlag = + commandAddAction command + { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do + let verbosity = fromFlagOrDefault normal (verbosityFlag flags) + load <- try (loadConfigOrSandboxConfig verbosity globalFlags) + let config = either (\(SomeException _) -> mempty) id load + distPref <- findSavedDistPref config (distPrefFlag flags) + let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } + setupWrapper verbosity setupScriptOptions Nothing + command (const flags) (const extraArgs) + +configureAction :: (ConfigFlags, ConfigExFlags) + -> [String] -> Action +configureAction (configFlags, configExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + config <- updateInstallDirs (configUserInstall configFlags) + <$> loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (configDistPref configFlags) + nixInstantiate verbosity distPref True globalFlags config + nixShell verbosity distPref globalFlags config $ do + let configFlags' = savedConfigureFlags config `mappend` configFlags + configExFlags' = savedConfigureExFlags config `mappend` configExFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAuxEx configFlags' + + writeConfigFlags verbosity distPref (configFlags', configExFlags') + + -- What package database(s) to use + let packageDBs :: PackageDBStack + packageDBs + = interpretPackageDbFlags + (fromFlag (configUserInstall configFlags')) + (configPackageDBs configFlags') + + withRepoContext verbosity globalFlags' $ \repoContext -> + configure verbosity packageDBs repoContext + comp platform progdb configFlags' configExFlags' extraArgs + +reconfigureAction :: (ConfigFlags, ConfigExFlags) + -> [String] -> Action +reconfigureAction flags@(configFlags, _) _ globalFlags = do + let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + config <- updateInstallDirs (configUserInstall configFlags) + <$> loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (configDistPref configFlags) + let checkFlags = Check $ \_ saved -> do + let flags' = saved <> flags + unless (saved == flags') $ info verbosity message + pure (Any True, flags') + where + -- This message is correct, but not very specific: it will list all + -- of the new flags, even if some have not actually changed. The + -- *minimal* set of changes is more difficult to determine. + message = + "flags changed: " + ++ unwords (commandShowOptions configureExCommand flags) + nixInstantiate verbosity distPref True globalFlags config + _ <- + reconfigure configureAction + verbosity distPref NoFlag + checkFlags [] globalFlags config + pure () + +buildAction :: BuildFlags -> [String] -> Action +buildAction buildFlags extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + config <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (buildDistPref buildFlags) + -- Calls 'configureAction' to do the real work, so nothing special has to be + -- done to support sandboxes. + config' <- + reconfigure configureAction + verbosity distPref (buildNumJobs buildFlags) + mempty [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + build verbosity config' distPref buildFlags extraArgs + + +-- | Actually do the work of building the package. This is separate from +-- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke +-- 'reconfigure' twice. +build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO () +build verbosity config distPref buildFlags extraArgs = + setupWrapper verbosity setupOptions Nothing + (Cabal.buildCommand progDb) mkBuildFlags (const extraArgs) + where + progDb = defaultProgramDb + setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + + mkBuildFlags version = filterBuildFlags version config buildFlags' + buildFlags' = buildFlags + { buildVerbosity = toFlag verbosity + , buildDistPref = toFlag distPref + } + +-- | Make sure that we don't pass new flags to setup scripts compiled against +-- old versions of Cabal. +filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags +filterBuildFlags version config buildFlags + | version >= mkVersion [1,19,1] = buildFlags_latest + -- Cabal < 1.19.1 doesn't support 'build -j'. + | otherwise = buildFlags_pre_1_19_1 + where + buildFlags_pre_1_19_1 = buildFlags { + buildNumJobs = NoFlag + } + buildFlags_latest = buildFlags { + -- Take the 'jobs' setting config file into account. + buildNumJobs = Flag . Just . determineNumJobs $ + (numJobsConfigFlag `mappend` numJobsCmdLineFlag) + } + numJobsConfigFlag = installNumJobs . savedInstallFlags $ config + numJobsCmdLineFlag = buildNumJobs buildFlags + + +replAction :: ReplFlags -> [String] -> Action +replAction replFlags extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (replVerbosity replFlags) + config <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (replDistPref replFlags) + cwd <- getCurrentDirectory + pkgDesc <- findPackageDesc cwd + let + -- There is a .cabal file in the current directory: start a REPL and load + -- the project's modules. + onPkgDesc = do + -- Calls 'configureAction' to do the real work, so nothing special has to + -- be done to support sandboxes. + _ <- + reconfigure configureAction + verbosity distPref NoFlag + mempty [] globalFlags config + let progDb = defaultProgramDb + setupOptions = defaultSetupScriptOptions + { useCabalVersion = orLaterVersion $ mkVersion [1,18,0] + , useDistPref = distPref + } + replFlags' = replFlags + { replVerbosity = toFlag verbosity + , replDistPref = toFlag distPref + } + + nixShell verbosity distPref globalFlags config $ + setupWrapper verbosity setupOptions Nothing (Cabal.replCommand progDb) (const replFlags') (const extraArgs) + + -- No .cabal file in the current directory: just start the REPL (possibly + -- using the sandbox package DB). + onNoPkgDesc = do + let configFlags = savedConfigureFlags config + (comp, platform, programDb) <- configCompilerAux' configFlags + programDb' <- reconfigurePrograms verbosity + (replProgramPaths replFlags) + (replProgramArgs replFlags) + programDb + nixShell verbosity distPref globalFlags config $ do + startInterpreter verbosity programDb' comp platform + (configPackageDB' configFlags) + + either (const onNoPkgDesc) (const onPkgDesc) pkgDesc + +installAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) + -> [String] -> Action +installAction (configFlags, _, installFlags, _, _, _) _ globalFlags + | fromFlagOrDefault False (installOnly installFlags) = do + let verb = fromFlagOrDefault normal (configVerbosity configFlags) + config <- loadConfigOrSandboxConfig verb globalFlags + dist <- findSavedDistPref config (configDistPref configFlags) + let setupOpts = defaultSetupScriptOptions { useDistPref = dist } + setupWrapper + verb setupOpts Nothing + installCommand (const (mempty, mempty, mempty, mempty, mempty, mempty)) + (const []) + +installAction + ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) + extraArgs globalFlags = do + let verb = fromFlagOrDefault normal (configVerbosity configFlags) + config <- updateInstallDirs (configUserInstall configFlags) + <$> loadConfigOrSandboxConfig verb globalFlags + + dist <- findSavedDistPref config (configDistPref configFlags) + + do + targets <- readUserTargets verb extraArgs + + let configFlags' = maybeForceTests installFlags' $ + savedConfigureFlags config `mappend` + configFlags { configDistPref = toFlag dist } + configExFlags' = defaultConfigExFlags `mappend` + savedConfigureExFlags config `mappend` configExFlags + installFlags' = defaultInstallFlags `mappend` + savedInstallFlags config `mappend` installFlags + haddockFlags' = defaultHaddockFlags `mappend` + savedHaddockFlags config `mappend` + haddockFlags { haddockDistPref = toFlag dist } + testFlags' = Cabal.defaultTestFlags `mappend` + savedTestFlags config `mappend` + testFlags { testDistPref = toFlag dist } + benchmarkFlags' = Cabal.defaultBenchmarkFlags `mappend` + savedBenchmarkFlags config `mappend` + benchmarkFlags { benchmarkDistPref = toFlag dist } + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags' + + -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the + -- future. + progdb' <- configureAllKnownPrograms verb progdb + + configFlags'' <- configAbsolutePaths configFlags' + + withRepoContext verb globalFlags' $ \repoContext -> + install verb + (configPackageDB' configFlags'') + repoContext + comp platform progdb' + globalFlags' configFlags'' configExFlags' + installFlags' haddockFlags' testFlags' benchmarkFlags' + targets + + where + -- '--run-tests' implies '--enable-tests'. + maybeForceTests installFlags' configFlags' = + if fromFlagOrDefault False (installRunTests installFlags') + then configFlags' { configTests = toFlag True } + else configFlags' + +testAction :: (BuildFlags, TestFlags) -> [String] -> GlobalFlags + -> IO () +testAction (buildFlags, testFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + config <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (testDistPref testFlags) + let buildFlags' = buildFlags + { buildVerbosity = testVerbosity testFlags } + checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> + if fromFlagOrDefault False (configTests configFlags) + then pure (mempty, flags) + else do + info verbosity "reconfiguring to enable tests" + let flags' = ( configFlags { configTests = toFlag True } + , configExFlags + ) + pure (Any True, flags') + + _ <- + reconfigure configureAction + verbosity distPref (buildNumJobs buildFlags') + checkFlags [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + testFlags' = testFlags { testDistPref = toFlag distPref } + + -- The package was just configured, so the LBI must be available. + names <- componentNamesFromLBI verbosity distPref "test suites" + (\c -> case c of { LBI.CTest{} -> True; _ -> False }) + let extraArgs' + | null extraArgs = case names of + ComponentNamesUnknown -> [] + ComponentNames names' -> [ Make.unUnqualComponentName name + | LBI.CTestName name <- names' ] + | otherwise = extraArgs + + build verbosity config distPref buildFlags' extraArgs' + setupWrapper verbosity setupOptions Nothing Cabal.testCommand (const testFlags') (const extraArgs') + +data ComponentNames = ComponentNamesUnknown + | ComponentNames [LBI.ComponentName] + +-- | Return the names of all buildable components matching a given predicate. +componentNamesFromLBI :: Verbosity -> FilePath -> String + -> (LBI.Component -> Bool) + -> IO ComponentNames +componentNamesFromLBI verbosity distPref targetsDescr compPred = do + eLBI <- tryGetPersistBuildConfig distPref + case eLBI of + Left err -> case err of + -- Note: the build config could have been generated by a custom setup + -- script built against a different Cabal version, so it's crucial that + -- we ignore the bad version error here. + ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown + _ -> die' verbosity (show err) + Right lbi -> do + let pkgDescr = LBI.localPkgDescr lbi + names = map LBI.componentName + . filter (buildable . LBI.componentBuildInfo) + . filter compPred $ + LBI.pkgComponents pkgDescr + if null names + then do notice verbosity $ "Package has no buildable " + ++ targetsDescr ++ "." + exitSuccess -- See #3215. + + else return $! (ComponentNames names) + +benchmarkAction :: (BuildFlags, BenchmarkFlags) + -> [String] -> GlobalFlags + -> IO () +benchmarkAction + (buildFlags, benchmarkFlags) + extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal + (buildVerbosity buildFlags) + + config <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags) + let buildFlags' = buildFlags + { buildVerbosity = benchmarkVerbosity benchmarkFlags } + + let checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> + if fromFlagOrDefault False (configBenchmarks configFlags) + then pure (mempty, flags) + else do + info verbosity "reconfiguring to enable benchmarks" + let flags' = ( configFlags { configBenchmarks = toFlag True } + , configExFlags + ) + pure (Any True, flags') + + config' <- + reconfigure configureAction + verbosity distPref (buildNumJobs buildFlags') + checkFlags [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref } + + -- The package was just configured, so the LBI must be available. + names <- componentNamesFromLBI verbosity distPref "benchmarks" + (\c -> case c of { LBI.CBench{} -> True; _ -> False; }) + let extraArgs' + | null extraArgs = case names of + ComponentNamesUnknown -> [] + ComponentNames names' -> [ Make.unUnqualComponentName name + | LBI.CBenchName name <- names'] + | otherwise = extraArgs + + build verbosity config' distPref buildFlags' extraArgs' + setupWrapper verbosity setupOptions Nothing Cabal.benchmarkCommand (const benchmarkFlags') (const extraArgs') + +haddockAction :: HaddockFlags -> [String] -> Action +haddockAction haddockFlags extraArgs globalFlags = do + let verbosity = fromFlag (haddockVerbosity haddockFlags) + config <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (haddockDistPref haddockFlags) + config' <- + reconfigure configureAction + verbosity distPref NoFlag + mempty [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + let haddockFlags' = defaultHaddockFlags `mappend` + savedHaddockFlags config' `mappend` + haddockFlags { haddockDistPref = toFlag distPref } + setupScriptOptions = defaultSetupScriptOptions + { useDistPref = distPref } + setupWrapper verbosity setupScriptOptions Nothing + haddockCommand (const haddockFlags') (const extraArgs) + when (haddockForHackage haddockFlags == Flag ForHackage) $ do + pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) + let dest = distPref name <.> "tar.gz" + name = display (packageId pkg) ++ "-docs" + docDir = distPref "doc" "html" + createTarGzFile dest docDir name + notice verbosity $ "Documentation tarball created: " ++ dest + +cleanAction :: CleanFlags -> [String] -> Action +cleanAction cleanFlags extraArgs globalFlags = do + load <- try (loadConfigOrSandboxConfig verbosity globalFlags) + let config = either (\(SomeException _) -> mempty) id load + distPref <- findSavedDistPref config (cleanDistPref cleanFlags) + let setupScriptOptions = defaultSetupScriptOptions + { useDistPref = distPref + , useWin32CleanHack = True + } + cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref } + setupWrapper verbosity setupScriptOptions Nothing + cleanCommand (const cleanFlags') (const extraArgs) + where + verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags) + +listAction :: ListFlags -> [String] -> Action +listAction listFlags extraArgs globalFlags = do + let verbosity = fromFlag (listVerbosity listFlags) + config <- loadConfigOrSandboxConfig verbosity globalFlags + let configFlags' = savedConfigureFlags config + configFlags = configFlags' + { configPackageDBs = configPackageDBs configFlags' + `mappend` listPackageDBs listFlags + , configHcPath = listHcPath listFlags + } + globalFlags' = savedGlobalFlags config `mappend` globalFlags + compProgdb <- if listNeedsCompiler listFlags + then do + (comp, _, progdb) <- configCompilerAux' configFlags + return (Just (comp, progdb)) + else return Nothing + withRepoContext verbosity globalFlags' $ \repoContext -> + List.list verbosity + (configPackageDB' configFlags) + repoContext + compProgdb + listFlags + extraArgs + +infoAction :: InfoFlags -> [String] -> Action +infoAction infoFlags extraArgs globalFlags = do + let verbosity = fromFlag (infoVerbosity infoFlags) + targets <- readUserTargets verbosity extraArgs + config <- loadConfigOrSandboxConfig verbosity globalFlags + let configFlags' = savedConfigureFlags config + configFlags = configFlags' { + configPackageDBs = configPackageDBs configFlags' + `mappend` infoPackageDBs infoFlags + } + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, _, progdb) <- configCompilerAuxEx configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + List.info verbosity + (configPackageDB' configFlags) + repoContext + comp + progdb + globalFlags' + infoFlags + targets + +fetchAction :: FetchFlags -> [String] -> Action +fetchAction fetchFlags extraArgs globalFlags = do + let verbosity = fromFlag (fetchVerbosity fetchFlags) + targets <- readUserTargets verbosity extraArgs + config <- loadConfig verbosity (globalConfigFile globalFlags) + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + fetch verbosity + (configPackageDB' configFlags) + repoContext + comp platform progdb globalFlags' fetchFlags + targets + +freezeAction :: FreezeFlags -> [String] -> Action +freezeAction freezeFlags _extraArgs globalFlags = do + let verbosity = fromFlag (freezeVerbosity freezeFlags) + config <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config NoFlag + nixShell verbosity distPref globalFlags config $ do + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags + + withRepoContext verbosity globalFlags' $ \repoContext -> + freeze verbosity + (configPackageDB' configFlags) + repoContext + comp platform progdb + globalFlags' freezeFlags + +genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () +genBoundsAction freezeFlags _extraArgs globalFlags = do + let verbosity = fromFlag (freezeVerbosity freezeFlags) + config <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config NoFlag + nixShell verbosity distPref globalFlags config $ do + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags + + withRepoContext verbosity globalFlags' $ \repoContext -> + genBounds verbosity + (configPackageDB' configFlags) + repoContext + comp platform progdb + globalFlags' freezeFlags + +uploadAction :: UploadFlags -> [String] -> Action +uploadAction uploadFlags extraArgs globalFlags = do + config <- loadConfig verbosity (globalConfigFile globalFlags) + let uploadFlags' = savedUploadFlags config `mappend` uploadFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + tarfiles = extraArgs + when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $ + die' verbosity "the 'upload' command expects at least one .tar.gz archive." + checkTarFiles extraArgs + maybe_password <- + case uploadPasswordCmd uploadFlags' + of Flag (xs:xss) -> Just . Password <$> + getProgramInvocationOutput verbosity + (simpleProgramInvocation xs xss) + _ -> pure $ flagToMaybe $ uploadPassword uploadFlags' + withRepoContext verbosity globalFlags' $ \repoContext -> do + if fromFlag (uploadDoc uploadFlags') + then do + when (length tarfiles > 1) $ + die' verbosity $ "the 'upload' command can only upload documentation " + ++ "for one package at a time." + tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles + Upload.uploadDoc verbosity + repoContext + (flagToMaybe $ uploadUsername uploadFlags') + maybe_password + (fromFlag (uploadCandidate uploadFlags')) + tarfile + else do + Upload.upload verbosity + repoContext + (flagToMaybe $ uploadUsername uploadFlags') + maybe_password + (fromFlag (uploadCandidate uploadFlags')) + tarfiles + where + verbosity = fromFlag (uploadVerbosity uploadFlags) + checkTarFiles tarfiles + | not (null otherFiles) + = die' verbosity $ "the 'upload' command expects only .tar.gz archives: " + ++ intercalate ", " otherFiles + | otherwise = sequence_ + [ do exists <- doesFileExist tarfile + unless exists $ die' verbosity $ "file not found: " ++ tarfile + | tarfile <- tarfiles ] + + where otherFiles = filter (not . isTarGzFile) tarfiles + isTarGzFile file = case splitExtension file of + (file', ".gz") -> takeExtension file' == ".tar" + _ -> False + generateDocTarball config = do + notice verbosity $ + "No documentation tarball specified. " + ++ "Building a documentation tarball with default settings...\n" + ++ "If you need to customise Haddock options, " + ++ "run 'haddock --for-hackage' first " + ++ "to generate a documentation tarball." + haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage }) + [] globalFlags + distPref <- findSavedDistPref config NoFlag + pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) + return $ distPref display (packageId pkg) ++ "-docs" <.> "tar.gz" + +checkAction :: Flag Verbosity -> [String] -> Action +checkAction verbosityFlag extraArgs _globalFlags = do + let verbosity = fromFlag verbosityFlag + unless (null extraArgs) $ + die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs + allOk <- Check.check (fromFlag verbosityFlag) + unless allOk exitFailure + +formatAction :: Flag Verbosity -> [String] -> Action +formatAction verbosityFlag extraArgs _globalFlags = do + let verbosity = fromFlag verbosityFlag + path <- case extraArgs of + [] -> do cwd <- getCurrentDirectory + tryFindPackageDesc verbosity cwd + (p:_) -> return p + pkgDesc <- readGenericPackageDescription verbosity path + -- Uses 'writeFileAtomic' under the hood. + writeGenericPackageDescription path pkgDesc + +reportAction :: ReportFlags -> [String] -> Action +reportAction reportFlags extraArgs globalFlags = do + let verbosity = fromFlag (reportVerbosity reportFlags) + unless (null extraArgs) $ + die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs + config <- loadConfig verbosity (globalConfigFile globalFlags) + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + reportFlags' = savedReportFlags config `mappend` reportFlags + + withRepoContext verbosity globalFlags' $ \repoContext -> + Upload.report verbosity repoContext + (flagToMaybe $ reportUsername reportFlags') + (flagToMaybe $ reportPassword reportFlags') + +runAction :: BuildFlags -> [String] -> Action +runAction buildFlags extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + config <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (buildDistPref buildFlags) + config' <- + reconfigure configureAction + verbosity distPref (buildNumJobs buildFlags) + mempty [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + lbi <- getPersistBuildConfig distPref + (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs + + build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)] + run verbosity lbi exe exeArgs + +getAction :: GetFlags -> [String] -> Action +getAction getFlags extraArgs globalFlags = do + let verbosity = fromFlag (getVerbosity getFlags) + targets <- readUserTargets verbosity extraArgs + config <- loadConfigOrSandboxConfig verbosity globalFlags + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + withRepoContext verbosity (savedGlobalFlags config) $ \repoContext -> + get verbosity + repoContext + globalFlags' + getFlags + targets + +unpackAction :: GetFlags -> [String] -> Action +unpackAction getFlags extraArgs globalFlags = do + getAction getFlags extraArgs globalFlags + +initAction :: InitFlags -> [String] -> Action +initAction initFlags extraArgs globalFlags = do + -- it takes the first value within extraArgs (if there's one) + -- and uses it as the root directory for the new project + case extraArgs of + [] -> initAction' + [projectDir] -> do + createDirectoryIfMissingVerbose verbosity True projectDir + withCurrentDirectory projectDir initAction' + _ -> die' verbosity $ + "'init' only takes a single, optional, extra " ++ + "argument for the project root directory" + where + initAction' = do + confFlags <- loadConfigOrSandboxConfig verbosity globalFlags + -- override with `--with-compiler` from CLI if available + let confFlags' = savedConfigureFlags confFlags `mappend` compFlags + initFlags' = savedInitFlags confFlags `mappend` initFlags + globalFlags' = savedGlobalFlags confFlags `mappend` globalFlags + + (comp, _, progdb) <- configCompilerAux' confFlags' + + withRepoContext verbosity globalFlags' $ \repoContext -> + initCmd verbosity (configPackageDB' confFlags') + repoContext comp progdb initFlags' + + verbosity = fromFlag (initVerbosity initFlags) + compFlags = mempty { configHcPath = initHcPath initFlags } + +userConfigAction :: UserConfigFlags -> [String] -> Action +userConfigAction ucflags extraArgs globalFlags = do + let verbosity = fromFlag (userConfigVerbosity ucflags) + frc = fromFlag (userConfigForce ucflags) + extraLines = fromFlag (userConfigAppendLines ucflags) + case extraArgs of + ("init":_) -> do + path <- configFile + fileExists <- doesFileExist path + if (not fileExists || (fileExists && frc)) + then void $ createDefaultConfigFile verbosity extraLines path + else die' verbosity $ path ++ " already exists." + ("diff":_) -> traverse_ putStrLn =<< userConfigDiff verbosity globalFlags extraLines + ("update":_) -> userConfigUpdate verbosity globalFlags extraLines + -- Error handling. + [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')" + _ -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs + where configFile = getConfigFilePath (globalConfigFile globalFlags) + +-- | Used as an entry point when cabal-install needs to invoke itself +-- as a setup script. This can happen e.g. when doing parallel builds. +-- +actAsSetupAction :: ActAsSetupFlags -> [String] -> Action +actAsSetupAction actAsSetupFlags args _globalFlags = + let bt = fromFlag (actAsSetupBuildType actAsSetupFlags) + in case bt of + Simple -> Simple.defaultMainArgs args + Configure -> Simple.defaultMainWithHooksArgs + Simple.autoconfUserHooks args + Make -> Make.defaultMainArgs args + Custom -> error "actAsSetupAction Custom" + +manpageAction :: [CommandSpec action] -> ManpageFlags -> [String] -> Action +manpageAction commands flags extraArgs _ = do + let verbosity = fromFlag (manpageVerbosity flags) + unless (null extraArgs) $ + die' verbosity $ "'man' doesn't take any extra arguments: " ++ unwords extraArgs + pname <- getProgName + let cabalCmd = if takeExtension pname == ".exe" + then dropExtension pname + else pname + manpageCmd cabalCmd commands flags diff --git a/src/Distribution/Client/ProjectConfig.hs b/src/Distribution/Client/ProjectConfig.hs --- a/src/Distribution/Client/ProjectConfig.hs +++ b/src/Distribution/Client/ProjectConfig.hs @@ -31,6 +31,7 @@ readProjectLocalFreezeConfig, reportParseResult, showProjectConfig, + withGlobalConfig, withProjectOrGlobalConfig, writeProjectLocalExtraConfig, writeProjectLocalFreezeConfig, @@ -461,6 +462,15 @@ renderBadProjectRoot :: BadProjectRoot -> String renderBadProjectRoot (BadProjectRootExplicitFile projectFile) = "The given project file '" ++ projectFile ++ "' does not exist." + +withGlobalConfig + :: Verbosity -- ^ verbosity + -> Flag FilePath -- ^ @--cabal-config@ + -> (ProjectConfig -> IO a) -- ^ with global + -> IO a +withGlobalConfig verbosity gcf with = do + globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf + with globalConfig withProjectOrGlobalConfig :: Verbosity -- ^ verbosity diff --git a/src/Distribution/Client/ProjectPlanning.hs b/src/Distribution/Client/ProjectPlanning.hs --- a/src/Distribution/Client/ProjectPlanning.hs +++ b/src/Distribution/Client/ProjectPlanning.hs @@ -321,9 +321,17 @@ } cliConfig = do + progsearchpath <- liftIO $ getSystemSearchPath + + let fileMonitorProjectConfig = newFileMonitor (distProjectCacheFile "config") + fileMonitorProjectConfigKey <- do configPath <- getConfigFilePath projectConfigConfigFile - return (configPath, distProjectFile "") + return (configPath, distProjectFile "", + (projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg), + progsearchpath, + packageConfigProgramPaths, + packageConfigProgramPathExtra) (projectConfig, localPackages) <- runRebuild distProjectRootDirectory @@ -354,18 +362,11 @@ where - ProjectConfigShared { projectConfigConfigFile } = - projectConfigShared cliConfig - - ProjectConfigShared { projectConfigIgnoreProject } = + ProjectConfigShared { projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg, projectConfigIgnoreProject, projectConfigConfigFile } = projectConfigShared cliConfig - fileMonitorProjectConfig :: - FileMonitor - (FilePath, FilePath) - (ProjectConfig, [PackageSpecifier UnresolvedSourcePackage]) - fileMonitorProjectConfig = - newFileMonitor (distProjectCacheFile "config") + PackageConfig { packageConfigProgramPaths, packageConfigProgramPathExtra } = + projectConfigLocalPackages cliConfig -- Read the cabal.project (or implicit config) and combine it with -- arguments from the command line diff --git a/src/Distribution/Client/ScriptUtils.hs b/src/Distribution/Client/ScriptUtils.hs --- a/src/Distribution/Client/ScriptUtils.hs +++ b/src/Distribution/Client/ScriptUtils.hs @@ -9,7 +9,8 @@ getScriptHash, getScriptCacheDirectory, ensureScriptCacheDirectory, withContextAndSelectors, AcceptNoTargets(..), TargetContext(..), updateContextAndWriteProjectFile, updateContextAndWriteProjectFile', - fakeProjectSourcePackage, lSrcpkgDescription + fakeProjectSourcePackage, lSrcpkgDescription, + movedExePath ) where import Prelude () @@ -24,22 +25,24 @@ import Distribution.Client.Config ( defaultScriptBuildsDir ) import Distribution.Client.DistDirLayout - ( DistDirLayout(..) ) + ( DistDirLayout(..), DistDirParams(..) ) import Distribution.Client.HashValue - ( hashValue, showHashValue ) + ( hashValue, showHashValueBase64 ) import Distribution.Client.HttpUtils ( HttpTransport, configureTransport ) import Distribution.Client.NixStyleOptions ( NixStyleFlags (..) ) import Distribution.Client.ProjectConfig - ( ProjectConfig(..), ProjectConfigShared(..) - , reportParseResult, withProjectOrGlobalConfig + ( ProjectConfig(..), ProjectConfigShared(..), PackageConfig(..) + , reportParseResult, withGlobalConfig, withProjectOrGlobalConfig , projectConfigHttpTransport ) import Distribution.Client.ProjectConfig.Legacy ( ProjectConfigSkeleton , parseProjectSkeleton, instantiateProjectConfigSkeletonFetchingCompiler ) import Distribution.Client.ProjectFlags ( flagIgnoreProject ) +import Distribution.Client.ProjectPlanning + ( ElaboratedSharedConfig(..), ElaboratedConfiguredPackage(..) ) import Distribution.Client.RebuildMonad ( runRebuild ) import Distribution.Client.Setup @@ -48,6 +51,8 @@ ( TargetSelectorProblem(..), TargetString(..) ) import Distribution.Client.Types ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage ) +import Distribution.Compiler + ( CompilerId(..), perCompilerFlavorToList ) import Distribution.FieldGrammar ( parseFieldGrammar, takeFields ) import Distribution.Fields @@ -67,7 +72,7 @@ import Distribution.Simple.Setup ( Flag(..) ) import Distribution.Simple.Compiler - ( compilerInfo ) + ( Compiler(..), OptimisationLevel(..), compilerInfo ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, createTempDirectory, die', handleDoesNotExist, readUTF8File, warn, writeUTF8File ) import qualified Distribution.SPDX.License as SPDX @@ -77,6 +82,8 @@ ( Platform(..) ) import Distribution.Types.BuildInfo ( BuildInfo(..) ) +import Distribution.Types.ComponentId + ( mkComponentId ) import Distribution.Types.CondTree ( CondTree(..) ) import Distribution.Types.Executable @@ -87,6 +94,10 @@ ( PackageDescription(..), emptyPackageDescription ) import Distribution.Types.PackageName.Magic ( fakePackageCabalFileName, fakePackageId ) +import Distribution.Types.UnitId + ( newSimpleUnitId ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName ) import Distribution.Utils.NubList ( fromNubList ) import Distribution.Client.ProjectPlanning @@ -106,7 +117,7 @@ import System.Directory ( canonicalizePath, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive ) import System.FilePath - ( (), takeFileName ) + ( (), makeRelative, takeDirectory, takeFileName ) import qualified Text.Parsec as P -- A note on multi-module script support #6787: @@ -125,7 +136,12 @@ -- Two hashes will be the same as long as the absolute paths -- are the same. getScriptHash :: FilePath -> IO String -getScriptHash script = showHashValue . hashValue . fromString <$> canonicalizePath script +getScriptHash script + -- Base64 is shorter than Base16, which helps avoid long path issues on windows + -- but it can contain /'s which aren't valid in file paths so replace them with + -- %'s. 26 chars / 130 bits is enough to practically avoid collisions. + = map (\c -> if c == '/' then '%' else c) . take 26 + . showHashValueBase64 . hashValue . fromString <$> canonicalizePath script -- | Get the directory for caching a script build. -- @@ -177,7 +193,7 @@ -> IO b withContextAndSelectors noTargets kind flags@NixStyleFlags {..} targetStrings globalFlags cmd act = withTemporaryTempDirectory $ \mkTmpDir -> do - (tc, ctx) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with (without mkTmpDir) + (tc, ctx) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject (withoutProject mkTmpDir) (tc', ctx', sels) <- case targetStrings of -- Only script targets may contain spaces and or end with ':'. @@ -209,19 +225,25 @@ globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) defaultTarget = [TargetPackage TargetExplicitNamed [fakePackageId] Nothing] - with = do + withProject = do ctx <- establishProjectBaseContext verbosity cliConfig cmd return (ProjectContext, ctx) - without mkDir globalConfig = do - distDirLayout <- establishDummyDistDirLayout verbosity (globalConfig <> cliConfig) =<< mkDir + withoutProject mkTmpDir globalConfig = do + distDirLayout <- establishDummyDistDirLayout verbosity (globalConfig <> cliConfig) =<< mkTmpDir ctx <- establishDummyProjectBaseContext verbosity (globalConfig <> cliConfig) distDirLayout [] cmd return (GlobalContext, ctx) + + scriptBaseCtx script globalConfig = do + let noDistDir = mempty { projectConfigShared = mempty { projectConfigDistDir = Flag "" } } + let cfg = noDistDir <> globalConfig <> cliConfig + rootDir <- ensureScriptCacheDirectory verbosity script + distDirLayout <- establishDummyDistDirLayout verbosity cfg rootDir + establishDummyProjectBaseContext verbosity cfg distDirLayout [] cmd + scriptOrError script err = do exists <- doesFileExist script if exists then do - -- In the script case we always want a dummy context even when ignoreProject is False - let mkCacheDir = ensureScriptCacheDirectory verbosity script - (_, ctx) <- withProjectOrGlobalConfig verbosity (Flag True) globalConfigFlag with (without mkCacheDir) + ctx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script) let projectRoot = distProjectRootDirectory $ distDirLayout ctx writeFile (projectRoot "scriptlocation") =<< canonicalizePath script @@ -236,14 +258,22 @@ projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents - let fetchCompiler = do - (compiler, Platform arch os, _) <- runRebuild (distProjectRootDirectory . distDirLayout $ ctx) $ configureCompiler verbosity (distDirLayout ctx) ((fst $ ignoreConditions projectCfgSkeleton) <> projectConfig ctx) - pure (os, arch, compilerInfo compiler) + createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx) + (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx) - projectCfg <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectCfgSkeleton + projectCfg <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compilerInfo compiler)) mempty projectCfgSkeleton - let executable' = executable & L.buildInfo . L.defaultLanguage %~ maybe (Just Haskell2010) Just - ctx' = ctx & lProjectConfig %~ (<> projectCfg) + let ctx' = ctx & lProjectConfig %~ (<> projectCfg) + + build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' compiler platform + exePath = build_dir "bin" scriptExeFileName script + exePathRel = makeRelative projectRoot exePath + + executable' = executable & L.buildInfo . L.defaultLanguage %~ maybe (Just Haskell2010) Just + & L.buildInfo . L.options %~ fmap (setExePath exePathRel) + + createDirectoryIfMissingVerbose verbosity True (takeDirectory exePath) + return (ScriptContext script executable', ctx', defaultTarget) else reportTargetSelectorProblems verbosity err @@ -260,6 +290,36 @@ return tmpDir rmTmp m _ = tryTakeMVar m >>= maybe (return ()) (handleDoesNotExist () . removeDirectoryRecursive) +scriptComponenetName :: IsString s => FilePath -> s +scriptComponenetName scriptPath = fromString cname + where + cname = "script-" ++ map censor (takeFileName scriptPath) + censor c | c `S.member` ccNamecore = c + | otherwise = '_' + +scriptExeFileName :: FilePath -> FilePath +scriptExeFileName scriptPath = "cabal-script-" ++ takeFileName scriptPath + +scriptDistDirParams :: FilePath -> ProjectBaseContext -> Compiler -> Platform -> DistDirParams +scriptDistDirParams scriptPath ctx compiler platform = DistDirParams + { distParamUnitId = newSimpleUnitId cid + , distParamPackageId = fakePackageId + , distParamComponentId = cid + , distParamComponentName = Just $ CExeName cn + , distParamCompilerId = compilerId compiler + , distParamPlatform = platform + , distParamOptimization = fromFlagOrDefault NormalOptimisation optimization + } + where + cn = scriptComponenetName scriptPath + cid = mkComponentId $ prettyShow fakePackageId <> "-inplace-" <> prettyShow cn + optimization = (packageConfigOptimization . projectConfigLocalPackages . projectConfig) ctx + +setExePath :: FilePath -> [String] -> [String] +setExePath exePath options + | "-o" `notElem` options = "-o" : exePath : options + | otherwise = options + -- | Add the 'SourcePackage' to the context and use it to write a .cabal file. updateContextAndWriteProjectFile' :: ProjectBaseContext -> SourcePackage (PackageLocation (Maybe FilePath)) -> IO ProjectBaseContext updateContextAndWriteProjectFile' ctx srcPkg = do @@ -284,15 +344,9 @@ absScript <- canonicalizePath scriptPath let - -- Replace characters which aren't allowed in the executable component name with '_' - -- Prefix with "cabal-script-" to make it clear to end users that the name may be mangled - scriptExeName = "cabal-script-" ++ map censor (takeFileName scriptPath) - censor c | c `S.member` ccNamecore = c - | otherwise = '_' - sourcePackage = fakeProjectSourcePackage projectRoot & lSrcpkgDescription . L.condExecutables - .~ [(fromString scriptExeName, CondNode executable (targetBuildDepends $ buildInfo executable) [])] + .~ [(scriptComponenetName scriptPath, CondNode executable (targetBuildDepends $ buildInfo executable) [])] executable = scriptExecutable & L.modulePath .~ absScript @@ -394,6 +448,15 @@ , specVersion = CabalSpecV2_2 , licenseRaw = Left SPDX.NONE } + +-- | Find the path of an exe that has been relocated with a "-o" option +movedExePath :: UnqualComponentName -> DistDirLayout -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> Maybe FilePath +movedExePath selectedComponent distDirLayout elabShared elabConfigured = do + exe <- find ((== selectedComponent) . exeName) . executables $ elabPkgDescription elabConfigured + let CompilerId flavor _ = (compilerId . pkgConfigCompiler) elabShared + opts <- lookup flavor (perCompilerFlavorToList . options $ buildInfo exe) + let projectRoot = distProjectRootDirectory distDirLayout + fmap (projectRoot ) . lookup "-o" $ reverse (zip opts (drop 1 opts)) -- Lenses -- | A lens for the 'srcpkgDescription' field of 'SourcePackage' diff --git a/src/Distribution/Client/Setup.hs b/src/Distribution/Client/Setup.hs --- a/src/Distribution/Client/Setup.hs +++ b/src/Distribution/Client/Setup.hs @@ -72,7 +72,11 @@ import qualified Distribution.Client.Init.Types as IT import qualified Distribution.Client.Init.Defaults as IT import Distribution.Client.Targets - ( UserConstraint, readUserConstraint ) + ( UserConstraint + , readUserConstraint + ) +import Distribution.Deprecated.ParseUtils (parseSpaceList, parseTokenQ) +import Distribution.Deprecated.ReadP (readP_to_E) import Distribution.Utils.NubList ( NubList, toNubList, fromNubList) @@ -369,7 +373,7 @@ optArg' "(True or False)" (maybeToFlag . (readMaybe =<<)) (\case Flag True -> [Just "enable"] Flag False -> [Just "disable"] - NoFlag -> [Just "disable"]) "" ["nix"] + NoFlag -> []) "" ["nix"] -- Must be empty because we need to return PP.empty from viewAsFieldDescr "Nix integration: run commands through nix-shell if a 'shell.nix' file exists (default is False)", noArg (Flag True) [] ["enable-nix"] "Enable Nix integration: run commands through nix-shell if a 'shell.nix' file exists", @@ -2004,51 +2008,77 @@ } uploadCommand :: CommandUI UploadFlags -uploadCommand = CommandUI { - commandName = "upload", - commandSynopsis = "Uploads source packages or documentation to Hackage.", - commandDescription = Nothing, - commandNotes = Just $ \_ -> - "You can store your Hackage login in the ~/.config/cabal/config file\n" - ++ relevantConfigValuesText ["username", "password", "password-command"], - commandUsage = \pname -> - "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n", - commandDefaultFlags = defaultUploadFlags, - commandOptions = \_ -> - [optionVerbosity uploadVerbosity - (\v flags -> flags { uploadVerbosity = v }) - - ,option [] ["publish"] - "Publish the package instead of uploading it as a candidate." - uploadCandidate (\v flags -> flags { uploadCandidate = v }) - (noArg (Flag IsPublished)) - - ,option ['d'] ["documentation"] - ("Upload documentation instead of a source package. " - ++ "By default, this uploads documentation for a package candidate. " - ++ "To upload documentation for " - ++ "a published package, combine with --publish.") - uploadDoc (\v flags -> flags { uploadDoc = v }) - trueArg - - ,option ['u'] ["username"] - "Hackage username." - uploadUsername (\v flags -> flags { uploadUsername = v }) - (reqArg' "USERNAME" (toFlag . Username) - (flagToList . fmap unUsername)) - - ,option ['p'] ["password"] - "Hackage password." - uploadPassword (\v flags -> flags { uploadPassword = v }) - (reqArg' "PASSWORD" (toFlag . Password) - (flagToList . fmap unPassword)) - - ,option ['P'] ["password-command"] - "Command to get Hackage password." - uploadPasswordCmd (\v flags -> flags { uploadPasswordCmd = v }) - (reqArg' "PASSWORD" (Flag . words) (fromMaybe [] . flagToMaybe)) - ] - } +uploadCommand = + CommandUI + { commandName = "upload" + , commandSynopsis = "Uploads source packages or documentation to Hackage." + , commandDescription = Nothing + , commandNotes = Just $ \_ -> + "You can store your Hackage login in the ~/.config/cabal/config file\n" + ++ relevantConfigValuesText ["username", "password", "password-command"] + , commandUsage = \pname -> + "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n" + , commandDefaultFlags = defaultUploadFlags + , commandOptions = \_ -> + [ optionVerbosity + uploadVerbosity + (\v flags -> flags{uploadVerbosity = v}) + , option + [] + ["publish"] + "Publish the package instead of uploading it as a candidate." + uploadCandidate + (\v flags -> flags{uploadCandidate = v}) + (noArg (Flag IsPublished)) + , option + ['d'] + ["documentation"] + ( "Upload documentation instead of a source package. " + ++ "By default, this uploads documentation for a package candidate. " + ++ "To upload documentation for " + ++ "a published package, combine with --publish." + ) + uploadDoc + (\v flags -> flags{uploadDoc = v}) + trueArg + , option + ['u'] + ["username"] + "Hackage username." + uploadUsername + (\v flags -> flags{uploadUsername = v}) + ( reqArg' + "USERNAME" + (toFlag . Username) + (flagToList . fmap unUsername) + ) + , option + ['p'] + ["password"] + "Hackage password." + uploadPassword + (\v flags -> flags{uploadPassword = v}) + ( reqArg' + "PASSWORD" + (toFlag . Password) + (flagToList . fmap unPassword) + ) + , option + ['P'] + ["password-command"] + "Command to get Hackage password." + uploadPasswordCmd + (\v flags -> flags{uploadPasswordCmd = v}) + ( reqArg + "COMMAND" + ( readP_to_E + ("Cannot parse command: " ++) + (Flag <$> parseSpaceList parseTokenQ) + ) + (flagElim [] (pure . unwords . fmap show)) + ) + ] + } instance Monoid UploadFlags where mempty = gmempty diff --git a/src/Distribution/Deprecated/ParseUtils.hs b/src/Distribution/Deprecated/ParseUtils.hs --- a/src/Distribution/Deprecated/ParseUtils.hs +++ b/src/Distribution/Deprecated/ParseUtils.hs @@ -21,25 +21,43 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE Rank2Types #-} -module Distribution.Deprecated.ParseUtils ( - LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning, - runP, runE, ParseResult(..), parseFail, showPWarning, - Field(..), lineNo, - FieldDescr(..), readFields, - parseHaskellString, parseTokenQ, - parseOptCommaList, - showFilePath, showToken, showFreeText, - field, simpleField, listField, listFieldWithSep, spaceListField, - newLineListField, - liftField, - readPToMaybe, - - fieldParsec, simpleFieldParsec, - listFieldParsec, - commaListFieldParsec, - commaNewLineListFieldParsec, - - UnrecFieldParser, +module Distribution.Deprecated.ParseUtils + ( LineNo + , PError (..) + , PWarning (..) + , locatedErrorMsg + , syntaxError + , warning + , runP + , runE + , ParseResult (..) + , parseFail + , showPWarning + , Field (..) + , lineNo + , FieldDescr (..) + , readFields + , parseHaskellString + , parseTokenQ + , parseSpaceList + , parseOptCommaList + , showFilePath + , showToken + , showFreeText + , field + , simpleField + , listField + , listFieldWithSep + , spaceListField + , newLineListField + , liftField + , readPToMaybe + , fieldParsec + , simpleFieldParsec + , listFieldParsec + , commaListFieldParsec + , commaNewLineListFieldParsec + , UnrecFieldParser ) where import Distribution.Client.Compat.Prelude hiding (get) diff --git a/tests/IntegrationTests2.hs b/tests/IntegrationTests2.hs --- a/tests/IntegrationTests2.hs +++ b/tests/IntegrationTests2.hs @@ -50,7 +50,7 @@ import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Simple.Setup (toFlag, HaddockFlags(..), defaultHaddockFlags) import Distribution.Client.Setup (globalCommand) -import Distribution.Client.Config (loadConfig, SavedConfig(savedGlobalFlags)) +import Distribution.Client.Config (loadConfig, SavedConfig(savedGlobalFlags), createDefaultConfigFile) import Distribution.Simple.Compiler import Distribution.Simple.Command import qualified Distribution.Simple.Flag as Flag @@ -62,6 +62,8 @@ import qualified Data.Map as Map import qualified Data.Set as Set +import Data.List (isInfixOf) + import Control.Monad import Control.Concurrent (threadDelay) import Control.Exception hiding (assert) @@ -73,6 +75,7 @@ import Test.Tasty.HUnit import Test.Tasty.Options import Data.Tagged (Tagged(..)) +import qualified Data.List as L import qualified Data.ByteString as BS import Distribution.Client.GlobalFlags (GlobalFlags, globalNix) @@ -149,6 +152,7 @@ , testGroup "Flag tests" $ [ testCase "Test Nix Flag" testNixFlags, + testCase "Test Config options for commented options" testConfigOptionComments, testCase "Test Ignore Project Flag" testIgnoreProjectFlag ] ] @@ -1958,13 +1962,12 @@ Nothing @=? (fromFlag . globalNix . fromJust $ nixDefaultFlags) -- Config file options - defaultConfig <- loadConfig verbosity (Flag (basedir "nix-config/default-config")) trueConfig <- loadConfig verbosity (Flag (basedir "nix-config/nix-true")) falseConfig <- loadConfig verbosity (Flag (basedir "nix-config/nix-false")) - Nothing @=? (fromFlag . globalNix . savedGlobalFlags $ defaultConfig) Just True @=? (fromFlag . globalNix . savedGlobalFlags $ trueConfig) Just False @=? (fromFlag . globalNix . savedGlobalFlags $ falseConfig) + where fromFlag :: Flag Bool -> Maybe Bool fromFlag (Flag x) = Just x @@ -1972,6 +1975,225 @@ getFlags :: CommandUI GlobalFlags -> CommandParse (GlobalFlags -> GlobalFlags, [String]) -> Maybe GlobalFlags getFlags cui (CommandReadyToGo (mkflags, _)) = Just . mkflags . commandDefaultFlags $ cui getFlags _ _ = Nothing + +-- Tests whether config options are commented or not +testConfigOptionComments :: Assertion +testConfigOptionComments = do + _ <- createDefaultConfigFile verbosity [] (basedir "config/default-config") + defaultConfigFile <- readFile (basedir "config/default-config") + + " url" @=? findLineWith False "url" defaultConfigFile + " -- secure" @=? findLineWith True "secure" defaultConfigFile + " -- root-keys" @=? findLineWith True "root-keys" defaultConfigFile + " -- key-threshold" @=? findLineWith True "key-threshold" defaultConfigFile + + "-- ignore-expiry" @=? findLineWith True "ignore-expiry" defaultConfigFile + "-- http-transport" @=? findLineWith True "http-transport" defaultConfigFile + "-- nix" @=? findLineWith True "nix" defaultConfigFile + "-- store-dir" @=? findLineWith True "store-dir" defaultConfigFile + "-- active-repositories" @=? findLineWith True "active-repositories" defaultConfigFile + "-- local-no-index-repo" @=? findLineWith True "local-no-index-repo" defaultConfigFile + "remote-repo-cache" @=? findLineWith False "remote-repo-cache" defaultConfigFile + "-- logs-dir" @=? findLineWith True "logs-dir" defaultConfigFile + "-- default-user-config" @=? findLineWith True "default-user-config" defaultConfigFile + "-- verbose" @=? findLineWith True "verbose" defaultConfigFile + "-- compiler" @=? findLineWith True "compiler" defaultConfigFile + "-- cabal-file" @=? findLineWith True "cabal-file" defaultConfigFile + "-- with-compiler" @=? findLineWith True "with-compiler" defaultConfigFile + "-- with-hc-pkg" @=? findLineWith True "with-hc-pkg" defaultConfigFile + "-- program-prefix" @=? findLineWith True "program-prefix" defaultConfigFile + "-- program-suffix" @=? findLineWith True "program-suffix" defaultConfigFile + "-- library-vanilla" @=? findLineWith True "library-vanilla" defaultConfigFile + "-- library-profiling" @=? findLineWith True "library-profiling" defaultConfigFile + "-- shared" @=? findLineWith True "shared" defaultConfigFile + "-- static" @=? findLineWith True "static" defaultConfigFile + "-- executable-dynamic" @=? findLineWith True "executable-dynamic" defaultConfigFile + "-- executable-static" @=? findLineWith True "executable-static" defaultConfigFile + "-- profiling" @=? findLineWith True "profiling" defaultConfigFile + "-- executable-profiling" @=? findLineWith True "executable-profiling" defaultConfigFile + "-- profiling-detail" @=? findLineWith True "profiling-detail" defaultConfigFile + "-- library-profiling-detail" @=? findLineWith True "library-profiling-detail" defaultConfigFile + "-- optimization" @=? findLineWith True "optimization" defaultConfigFile + "-- debug-info" @=? findLineWith True "debug-info" defaultConfigFile + "-- build-info" @=? findLineWith True "build-info" defaultConfigFile + "-- library-for-ghci" @=? findLineWith True "library-for-ghci" defaultConfigFile + "-- split-sections" @=? findLineWith True "split-sections" defaultConfigFile + "-- split-objs" @=? findLineWith True "split-objs" defaultConfigFile + "-- executable-stripping" @=? findLineWith True "executable-stripping" defaultConfigFile + "-- library-stripping" @=? findLineWith True "library-stripping" defaultConfigFile + "-- configure-option" @=? findLineWith True "configure-option" defaultConfigFile + "-- user-install" @=? findLineWith True "user-install" defaultConfigFile + "-- package-db" @=? findLineWith True "package-db" defaultConfigFile + "-- flags" @=? findLineWith True "flags" defaultConfigFile + "-- extra-include-dirs" @=? findLineWith True "extra-include-dirs" defaultConfigFile + "-- deterministic" @=? findLineWith True "deterministic" defaultConfigFile + "-- cid" @=? findLineWith True "cid" defaultConfigFile + "-- extra-lib-dirs" @=? findLineWith True "extra-lib-dirs" defaultConfigFile + "-- extra-lib-dirs-static" @=? findLineWith True "extra-lib-dirs-static" defaultConfigFile + "-- extra-framework-dirs" @=? findLineWith True "extra-framework-dirs" defaultConfigFile + "-- extra-prog-path" @=? findLineWith False "extra-prog-path" defaultConfigFile + "-- instantiate-with" @=? findLineWith True "instantiate-with" defaultConfigFile + "-- tests" @=? findLineWith True "tests" defaultConfigFile + "-- coverage" @=? findLineWith True "coverage" defaultConfigFile + "-- library-coverage" @=? findLineWith True "library-coverage" defaultConfigFile + "-- exact-configuration" @=? findLineWith True "exact-configuration" defaultConfigFile + "-- benchmarks" @=? findLineWith True "benchmarks" defaultConfigFile + "-- relocatable" @=? findLineWith True "relocatable" defaultConfigFile + "-- response-files" @=? findLineWith True "response-files" defaultConfigFile + "-- allow-depending-on-private-libs" @=? findLineWith True "allow-depending-on-private-libs" defaultConfigFile + "-- cabal-lib-version" @=? findLineWith True "cabal-lib-version" defaultConfigFile + "-- append" @=? findLineWith True "append" defaultConfigFile + "-- backup" @=? findLineWith True "backup" defaultConfigFile + "-- constraint" @=? findLineWith True "constraint" defaultConfigFile + "-- preference" @=? findLineWith True "preference" defaultConfigFile + "-- solver" @=? findLineWith True "solver" defaultConfigFile + "-- allow-older" @=? findLineWith True "allow-older" defaultConfigFile + "-- allow-newer" @=? findLineWith True "allow-newer" defaultConfigFile + "-- write-ghc-environment-files" @=? findLineWith True "write-ghc-environment-files" defaultConfigFile + "-- documentation" @=? findLineWith True "documentation" defaultConfigFile + "-- doc-index-file" @=? findLineWith True "doc-index-file" defaultConfigFile + "-- only-download" @=? findLineWith True "only-download" defaultConfigFile + "-- target-package-db" @=? findLineWith True "target-package-db" defaultConfigFile + "-- max-backjumps" @=? findLineWith True "max-backjumps" defaultConfigFile + "-- reorder-goals" @=? findLineWith True "reorder-goals" defaultConfigFile + "-- count-conflicts" @=? findLineWith True "count-conflicts" defaultConfigFile + "-- fine-grained-conflicts" @=? findLineWith True "fine-grained-conflicts" defaultConfigFile + "-- minimize-conflict-set" @=? findLineWith True "minimize-conflict-set" defaultConfigFile + "-- independent-goals" @=? findLineWith True "independent-goals" defaultConfigFile + "-- prefer-oldest" @=? findLineWith True "prefer-oldest" defaultConfigFile + "-- shadow-installed-packages" @=? findLineWith True "shadow-installed-packages" defaultConfigFile + "-- strong-flags" @=? findLineWith True "strong-flags" defaultConfigFile + "-- allow-boot-library-installs" @=? findLineWith True "allow-boot-library-installs" defaultConfigFile + "-- reject-unconstrained-dependencies" @=? findLineWith True "reject-unconstrained-dependencies" defaultConfigFile + "-- reinstall" @=? findLineWith True "reinstall" defaultConfigFile + "-- avoid-reinstalls" @=? findLineWith True "avoid-reinstalls" defaultConfigFile + "-- force-reinstalls" @=? findLineWith True "force-reinstalls" defaultConfigFile + "-- upgrade-dependencies" @=? findLineWith True "upgrade-dependencies" defaultConfigFile + "-- index-state" @=? findLineWith True "index-state" defaultConfigFile + "-- root-cmd" @=? findLineWith True "root-cmd" defaultConfigFile + "-- symlink-bindir" @=? findLineWith True "symlink-bindir" defaultConfigFile + "build-summary" @=? findLineWith False "build-summary" defaultConfigFile + "-- build-log" @=? findLineWith True "build-log" defaultConfigFile + "remote-build-reporting" @=? findLineWith False "remote-build-reporting" defaultConfigFile + "-- report-planning-failure" @=? findLineWith True "report-planning-failure" defaultConfigFile + "-- per-component" @=? findLineWith True "per-component" defaultConfigFile + "-- run-tests" @=? findLineWith True "run-tests" defaultConfigFile + "jobs" @=? findLineWith False "jobs" defaultConfigFile + "-- keep-going" @=? findLineWith True "keep-going" defaultConfigFile + "-- offline" @=? findLineWith True "offline" defaultConfigFile + "-- lib" @=? findLineWith True "lib" defaultConfigFile + "-- package-env" @=? findLineWith True "package-env" defaultConfigFile + "-- overwrite-policy" @=? findLineWith True "overwrite-policy" defaultConfigFile + "-- install-method" @=? findLineWith True "install-method" defaultConfigFile + "installdir" @=? findLineWith False "installdir" defaultConfigFile + "-- username" @=? findLineWith True "username" defaultConfigFile + "-- password" @=? findLineWith True "password" defaultConfigFile + "-- password-command" @=? findLineWith True "password-command" defaultConfigFile + "-- builddir" @=? findLineWith True "builddir" defaultConfigFile + + " -- keep-temp-files" @=? findLineWith True "keep-temp-files" defaultConfigFile + " -- hoogle" @=? findLineWith True "hoogle" defaultConfigFile + " -- html" @=? findLineWith True "html" defaultConfigFile + " -- html-location" @=? findLineWith True "html-location" defaultConfigFile + " -- executables" @=? findLineWith True "executables" defaultConfigFile + " -- foreign-libraries" @=? findLineWith True "foreign-libraries" defaultConfigFile + " -- all" @=? findLineWith True "all" defaultConfigFile + " -- internal" @=? findLineWith True "internal" defaultConfigFile + " -- css" @=? findLineWith True "css" defaultConfigFile + " -- hyperlink-source" @=? findLineWith True "hyperlink-source" defaultConfigFile + " -- quickjump" @=? findLineWith True "quickjump" defaultConfigFile + " -- hscolour-css" @=? findLineWith True "hscolour-css" defaultConfigFile + " -- contents-location" @=? findLineWith True "contents-location" defaultConfigFile + " -- index-location" @=? findLineWith True "index-location" defaultConfigFile + " -- base-url" @=? findLineWith True "base-url" defaultConfigFile + + " -- interactive" @=? findLineWith True "interactive" defaultConfigFile + " -- cabal-version" @=? findLineWith True "cabal-version" defaultConfigFile + " -- license" @=? findLineWith True "license" defaultConfigFile + " -- extra-doc-file" @=? findLineWith True "extra-doc-file" defaultConfigFile + " -- test-dir" @=? findLineWith True "test-dir" defaultConfigFile + " -- language" @=? findLineWith True "language" defaultConfigFile + " -- application-dir" @=? findLineWith True "application-dir" defaultConfigFile + " -- source-dir" @=? findLineWith True "source-dir" defaultConfigFile + + " -- prefix" @=? findLineWith True "prefix" defaultConfigFile + " -- bindir"@=? findLineWith True "bindir" defaultConfigFile + " -- libdir" @=? findLineWith True "libdir" defaultConfigFile + " -- libsubdir" @=? findLineWith True "libsubdir" defaultConfigFile + " -- dynlibdir" @=? findLineWith True "dynlibdir" defaultConfigFile + " -- libexecdir" @=? findLineWith True "libexecdir" defaultConfigFile + " -- libexecsubdir" @=? findLineWith True "libexecsubdir" defaultConfigFile + " -- datadir" @=? findLineWith True "datadir" defaultConfigFile + " -- datasubdir" @=? findLineWith True "datasubdir" defaultConfigFile + " -- docdir" @=? findLineWith True "docdir" defaultConfigFile + " -- htmldir" @=? findLineWith True "htmldir" defaultConfigFile + " -- haddockdir" @=? findLineWith True "haddockdir" defaultConfigFile + " -- sysconfdir" @=? findLineWith True "sysconfdir" defaultConfigFile + + " -- alex-location" @=? findLineWith True "alex-location" defaultConfigFile + " -- ar-location" @=? findLineWith True "ar-location" defaultConfigFile + " -- c2hs-location" @=? findLineWith True "c2hs-location" defaultConfigFile + " -- cpphs-location" @=? findLineWith True "cpphs-location" defaultConfigFile + " -- doctest-location" @=? findLineWith True "doctest-location" defaultConfigFile + " -- gcc-location" @=? findLineWith True "gcc-location" defaultConfigFile + " -- ghc-location" @=? findLineWith True "ghc-location" defaultConfigFile + " -- ghc-pkg-location" @=? findLineWith True "ghc-pkg-location" defaultConfigFile + " -- ghcjs-location" @=? findLineWith True "ghcjs-location" defaultConfigFile + " -- ghcjs-pkg-location" @=? findLineWith True "ghcjs-pkg-location" defaultConfigFile + " -- greencard-location" @=? findLineWith True "greencard-location" defaultConfigFile + " -- haddock-location" @=? findLineWith True "haddock-location" defaultConfigFile + " -- happy-location" @=? findLineWith True "happy-location" defaultConfigFile + " -- haskell-suite-location" @=? findLineWith True "haskell-suite-location" defaultConfigFile + " -- haskell-suite-pkg-location" @=? findLineWith True "haskell-suite-pkg-location" defaultConfigFile + " -- hmake-location" @=? findLineWith True "hmake-location" defaultConfigFile + " -- hpc-location" @=? findLineWith True "hpc-location" defaultConfigFile + " -- hscolour-location" @=? findLineWith True "hscolour-location" defaultConfigFile + " -- jhc-location" @=? findLineWith True "jhc-location" defaultConfigFile + " -- ld-location" @=? findLineWith True "ld-location" defaultConfigFile + " -- pkg-config-location" @=? findLineWith True "pkg-config-location" defaultConfigFile + " -- runghc-location" @=? findLineWith True "runghc-location" defaultConfigFile + " -- strip-location" @=? findLineWith True "strip-location" defaultConfigFile + " -- tar-location" @=? findLineWith True "tar-location" defaultConfigFile + " -- uhc-location" @=? findLineWith True "uhc-location" defaultConfigFile + + " -- alex-options" @=? findLineWith True "alex-options" defaultConfigFile + " -- ar-options" @=? findLineWith True "ar-options" defaultConfigFile + " -- c2hs-options" @=? findLineWith True "c2hs-options" defaultConfigFile + " -- cpphs-options" @=? findLineWith True "cpphs-options" defaultConfigFile + " -- doctest-options" @=? findLineWith True "doctest-options" defaultConfigFile + " -- gcc-options" @=? findLineWith True "gcc-options" defaultConfigFile + " -- ghc-options" @=? findLineWith True "ghc-options" defaultConfigFile + " -- ghc-pkg-options" @=? findLineWith True "ghc-pkg-options" defaultConfigFile + " -- ghcjs-options" @=? findLineWith True "ghcjs-options" defaultConfigFile + " -- ghcjs-pkg-options" @=? findLineWith True "ghcjs-pkg-options" defaultConfigFile + " -- greencard-options" @=? findLineWith True "greencard-options" defaultConfigFile + " -- haddock-options" @=? findLineWith True "haddock-options" defaultConfigFile + " -- happy-options" @=? findLineWith True "happy-options" defaultConfigFile + " -- haskell-suite-options" @=? findLineWith True "haskell-suite-options" defaultConfigFile + " -- haskell-suite-pkg-options" @=? findLineWith True "haskell-suite-pkg-options" defaultConfigFile + " -- hmake-options" @=? findLineWith True "hmake-options" defaultConfigFile + " -- hpc-options" @=? findLineWith True "hpc-options" defaultConfigFile + " -- hsc2hs-options" @=? findLineWith True "hsc2hs-options" defaultConfigFile + " -- hscolour-options" @=? findLineWith True "hscolour-options" defaultConfigFile + " -- jhc-options" @=? findLineWith True "jhc-options" defaultConfigFile + " -- ld-options" @=? findLineWith True "ld-options" defaultConfigFile + " -- pkg-config-options" @=? findLineWith True "pkg-config-options" defaultConfigFile + " -- runghc-options" @=? findLineWith True "runghc-options" defaultConfigFile + " -- strip-options" @=? findLineWith True "strip-options" defaultConfigFile + " -- tar-options" @=? findLineWith True "tar-options" defaultConfigFile + " -- uhc-options" @=? findLineWith True "uhc-options" defaultConfigFile + where + -- | Find lines containing a target string. + findLineWith :: Bool -> String -> String -> String + findLineWith isComment target text + | not . null $ findLinesWith isComment target text = removeCommentValue . L.head $ findLinesWith isComment target text + | otherwise = text + findLinesWith :: Bool -> String -> String -> [String] + findLinesWith isComment target + | isComment = filter (isInfixOf (" " ++ target ++ ":")) . lines + | otherwise = filter (isInfixOf (target ++ ":")) . lines + removeCommentValue :: String -> String + removeCommentValue = takeWhile (/= ':') testIgnoreProjectFlag :: Assertion testIgnoreProjectFlag = do diff --git a/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs --- a/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -44,7 +44,7 @@ import Data.Coerce (Coercible, coerce) import Network.URI (URI (..), URIAuth (..), isUnreserved) import Test.QuickCheck -import Test.QuickCheck.GenericArbitrary +import Test.QuickCheck.GenericArbitrary (genericArbitrary) import Test.QuickCheck.Instances.Cabal () -- note: there are plenty of instances defined in ProjectConfig test file. @@ -106,11 +106,6 @@ ------------------------------------------------------------------------------- -- cabal-install (and Cabal) types ------------------------------------------------------------------------------- - -shrinkBoundedEnum :: (Eq a, Enum a, Bounded a) => a -> [a] -shrinkBoundedEnum x - | x == minBound = [] - | otherwise = [pred x] adjustSize :: (Int -> Int) -> Gen a -> Gen a adjustSize adjust gen = sized (\n -> resize (adjust n) gen) diff --git a/tests/UnitTests/Distribution/Client/Init/FileCreators.hs b/tests/UnitTests/Distribution/Client/Init/FileCreators.hs --- a/tests/UnitTests/Distribution/Client/Init/FileCreators.hs +++ b/tests/UnitTests/Distribution/Client/Init/FileCreators.hs @@ -44,7 +44,9 @@ } inputs = -- createProject stuff - [ "True" + [ "Foobar" + , "foobar@qux.com" + , "True" , "[\"quxTest/Main.hs\"]" -- writeProject stuff -- writeLicense diff --git a/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs b/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs --- a/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs +++ b/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs @@ -73,7 +73,9 @@ , dependencies = Flag [] } inputs = NEL.fromList - [ "True" + ["Foobar" + , "foobar@qux.com" + , "True" , "[\"quxTest/Main.hs\"]" ] @@ -149,8 +151,11 @@ , dependencies = Flag [] } inputs = NEL.fromList + + [ "Foobar" + , "foobar@qux.com" -- extra sources - [ "[\"CHANGELOG.md\"]" + , "[\"CHANGELOG.md\"]" -- lib other modules , "False" -- exe other modules diff --git a/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/tests/UnitTests/Distribution/Solver/Modular/Solver.hs --- a/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -155,10 +155,6 @@ solverSuccess [("base", 1), ("ghc-prim", 1), ("integer-gmp", 1), ("integer-simple", 1)] , runTest $ mkTest dbNonupgrade "Refuse to install newer ghc requested by another library" ["A"] $ solverFailure (isInfixOf "rejecting: ghc-2.0.0 (constraint from non-upgradeable package requires installed instance)") - , runTest $ mkTest dbNonupgrade "Refuse to install newer ghci requested by another library" ["B"] $ - solverFailure (isInfixOf "rejecting: ghci-2.0.0 (constraint from non-upgradeable package requires installed instance)") - , runTest $ mkTest dbNonupgrade "Refuse to install newer ghc-boot requested by another library" ["C"] $ - solverFailure (isInfixOf "rejecting: ghc-boot-2.0.0 (constraint from non-upgradeable package requires installed instance)") ] , testGroup "reject-unconstrained" [ runTest $ onlyConstrained $ mkTest db12 "missing syb" ["E"] $ @@ -1132,14 +1128,8 @@ dbNonupgrade :: ExampleDb dbNonupgrade = [ Left $ exInst "ghc" 1 "ghc-1" [] - , Left $ exInst "ghci" 1 "ghci-1" [] - , Left $ exInst "ghc-boot" 1 "ghc-boot-1" [] , Right $ exAv "ghc" 2 [] - , Right $ exAv "ghci" 2 [] - , Right $ exAv "ghc-boot" 2 [] , Right $ exAv "A" 1 [ExFix "ghc" 2] - , Right $ exAv "B" 1 [ExFix "ghci" 2] - , Right $ exAv "C" 1 [ExFix "ghc-boot" 2] ] db13 :: ExampleDb