diff --git a/Distribution/Client/BuildReports/Anonymous.hs b/Distribution/Client/BuildReports/Anonymous.hs --- a/Distribution/Client/BuildReports/Anonymous.hs +++ b/Distribution/Client/BuildReports/Anonymous.hs @@ -47,16 +47,16 @@ ( OS, Arch ) import Distribution.Compiler ( CompilerId(..) ) -import qualified Distribution.Text as Text +import qualified Distribution.Deprecated.Text as Text ( Text(disp, parse) ) -import Distribution.ParseUtils +import Distribution.Deprecated.ParseUtils ( FieldDescr(..), ParseResult(..), Field(..) , simpleField, listField, ppFields, readFields , syntaxError, locatedErrorMsg ) import Distribution.Simple.Utils ( comparing ) -import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Deprecated.ReadP as Parse ( ReadP, pfail, munch1, skipSpaces ) import qualified Text.PrettyPrint as Disp ( Doc, render, char, text ) diff --git a/Distribution/Client/BuildReports/Types.hs b/Distribution/Client/BuildReports/Types.hs --- a/Distribution/Client/BuildReports/Types.hs +++ b/Distribution/Client/BuildReports/Types.hs @@ -15,10 +15,10 @@ ReportLevel(..), ) where -import qualified Distribution.Text as Text +import qualified Distribution.Deprecated.Text as Text ( Text(..) ) -import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Deprecated.ReadP as Parse ( pfail, munch1 ) import qualified Text.PrettyPrint as Disp ( text ) diff --git a/Distribution/Client/BuildReports/Upload.hs b/Distribution/Client/BuildReports/Upload.hs --- a/Distribution/Client/BuildReports/Upload.hs +++ b/Distribution/Client/BuildReports/Upload.hs @@ -23,7 +23,7 @@ ( () ) import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import Distribution.Client.BuildReports.Anonymous (BuildReport) -import Distribution.Text (display) +import Distribution.Deprecated.Text (display) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils (die') import Distribution.Client.HttpUtils diff --git a/Distribution/Client/Check.hs b/Distribution/Client/Check.hs --- a/Distribution/Client/Check.hs +++ b/Distribution/Client/Check.hs @@ -16,17 +16,20 @@ check ) where + import Distribution.Client.Compat.Prelude import Prelude () +import Distribution.Client.Utils.Parsec (renderParseError) import Distribution.PackageDescription (GenericPackageDescription) import Distribution.PackageDescription.Check import Distribution.PackageDescription.Configuration (flattenPackageDescription) import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, runParseResult) -import Distribution.Parsec.Common (PWarning (..), showPError, showPWarning) +import Distribution.Parsec (PWarning (..), showPError, showPWarning) import Distribution.Simple.Utils (defaultPackageDesc, die', notice, warn) import Distribution.Verbosity (Verbosity) +import System.IO (hPutStr, stderr) import qualified Data.ByteString as BS import qualified System.Directory as Dir @@ -42,7 +45,8 @@ case result of Left (_, errors) -> do traverse_ (warn verbosity . showPError fpath) errors - die' verbosity $ "Failed parsing \"" ++ fpath ++ "\"." + hPutStr stderr $ renderParseError fpath bs errors warnings + die' verbosity "parse error" Right x -> return (warnings, x) -- | Note: must be called with the CWD set to the directory containing diff --git a/Distribution/Client/CmdBench.hs b/Distribution/Client/CmdBench.hs --- a/Distribution/Client/CmdBench.hs +++ b/Distribution/Client/CmdBench.hs @@ -20,10 +20,10 @@ ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags, fromFlagOrDefault ) + ( HaddockFlags, TestFlags, fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) -import Distribution.Text +import Distribution.Deprecated.Text ( display ) import Distribution.Verbosity ( Verbosity, normal ) @@ -33,11 +33,11 @@ import Control.Monad (when) -benchCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +benchCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) benchCommand = Client.installCommand { - commandName = "new-bench", + commandName = "v2-bench", commandSynopsis = "Run benchmarks", - commandUsage = usageAlternatives "new-bench" [ "[TARGETS] [FLAGS]" ], + commandUsage = usageAlternatives "v2-bench" [ "[TARGETS] [FLAGS]" ], commandDescription = Just $ \_ -> wrapText $ "Runs the specified benchmarks, first ensuring they are up to " ++ "date.\n\n" @@ -53,13 +53,13 @@ ++ "'cabal.project.local' and other files.", commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " new-bench\n" + ++ " " ++ pname ++ " v2-bench\n" ++ " Run all the benchmarks in the package in the current directory\n" - ++ " " ++ pname ++ " new-bench pkgname\n" + ++ " " ++ pname ++ " v2-bench pkgname\n" ++ " Run all the benchmarks in the package named pkgname\n" - ++ " " ++ pname ++ " new-bench cname\n" + ++ " " ++ pname ++ " v2-bench cname\n" ++ " Run the benchmark named cname\n" - ++ " " ++ pname ++ " new-bench cname -O2\n" + ++ " " ++ pname ++ " v2-bench cname -O2\n" ++ " Run the benchmark built with '-O2' (including local libs used)\n\n" ++ cmdCommonHelpTextNewBuildBeta @@ -73,12 +73,12 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -benchAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +benchAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) -> [String] -> GlobalFlags -> IO () -benchAction (configFlags, configExFlags, installFlags, haddockFlags) +benchAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) targetStrings globalFlags = do - baseCtx <- establishProjectBaseContext verbosity cliConfig + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand targetSelectors <- either (reportTargetSelectorProblems verbosity) return =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings @@ -117,7 +117,9 @@ verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/Distribution/Client/CmdBuild.hs b/Distribution/Client/CmdBuild.hs --- a/Distribution/Client/CmdBuild.hs +++ b/Distribution/Client/CmdBuild.hs @@ -20,7 +20,8 @@ , liftOptions, yesNoOpt ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags, Flag(..), toFlag, fromFlag, fromFlagOrDefault ) + ( HaddockFlags, TestFlags + , Flag(..), toFlag, fromFlag, fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives, option ) import Distribution.Verbosity @@ -31,11 +32,14 @@ import qualified Data.Map as Map -buildCommand :: CommandUI (BuildFlags, (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)) +buildCommand :: + CommandUI + (BuildFlags, ( ConfigFlags, ConfigExFlags + , InstallFlags, HaddockFlags, TestFlags)) buildCommand = CommandUI { - commandName = "new-build", + commandName = "v2-build", commandSynopsis = "Compile targets within the project.", - commandUsage = usageAlternatives "new-build" [ "[TARGETS] [FLAGS]" ], + commandUsage = usageAlternatives "v2-build" [ "[TARGETS] [FLAGS]" ], commandDescription = Just $ \_ -> wrapText $ "Build one or more targets from within the project. The available " ++ "targets are the packages in the project as well as individual " @@ -50,16 +54,18 @@ ++ "'cabal.project.local' and other files.", commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " new-build\n" - ++ " Build the package in the current directory or all packages in the project\n" - ++ " " ++ pname ++ " new-build pkgname\n" + ++ " " ++ pname ++ " v2-build\n" + ++ " Build the package in the current directory " + ++ "or all packages in the project\n" + ++ " " ++ pname ++ " v2-build pkgname\n" ++ " Build the package named pkgname in the project\n" - ++ " " ++ pname ++ " new-build ./pkgfoo\n" + ++ " " ++ pname ++ " v2-build ./pkgfoo\n" ++ " Build the package in the ./pkgfoo directory\n" - ++ " " ++ pname ++ " new-build cname\n" + ++ " " ++ pname ++ " v2-build cname\n" ++ " Build the component named cname in the project\n" - ++ " " ++ pname ++ " new-build cname --enable-profiling\n" - ++ " Build the component in profiling mode (including dependencies as needed)\n\n" + ++ " " ++ pname ++ " v2-build cname --enable-profiling\n" + ++ " Build the component in profiling mode " + ++ "(including dependencies as needed)\n\n" ++ cmdCommonHelpTextNewBuildBeta, commandDefaultFlags = @@ -95,10 +101,13 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -buildAction :: (BuildFlags, (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)) - -> [String] -> GlobalFlags -> IO () -buildAction (buildFlags, - (configFlags, configExFlags, installFlags, haddockFlags)) +buildAction :: + ( BuildFlags + , (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)) + -> [String] -> GlobalFlags -> IO () +buildAction + ( buildFlags + , (configFlags, configExFlags, installFlags, haddockFlags, testFlags)) targetStrings globalFlags = do -- TODO: This flags defaults business is ugly let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags @@ -107,10 +116,11 @@ | onlyConfigure = TargetActionConfigure | otherwise = TargetActionBuild - baseCtx <- establishProjectBaseContext verbosity cliConfig + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings + targetSelectors <- + either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -147,14 +157,17 @@ verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, -- or otherwise classifies the problem. -- --- For the @build@ command select all components except non-buildable and disabled --- tests\/benchmarks, fail if there are no such components +-- For the @build@ command select all components except non-buildable +-- and disabled tests\/benchmarks, fail if there are no such +-- components -- selectPackageTargets :: TargetSelector -> [AvailableTarget k] -> Either TargetProblem [k] diff --git a/Distribution/Client/CmdClean.hs b/Distribution/Client/CmdClean.hs --- a/Distribution/Client/CmdClean.hs +++ b/Distribution/Client/CmdClean.hs @@ -49,7 +49,7 @@ cleanCommand :: CommandUI CleanFlags cleanCommand = CommandUI - { commandName = "new-clean" + { commandName = "v2-clean" , commandSynopsis = "Clean the package store and remove temporary files." , commandUsage = \pname -> "Usage: " ++ pname ++ " new-clean [FLAGS]\n" diff --git a/Distribution/Client/CmdConfigure.hs b/Distribution/Client/CmdConfigure.hs --- a/Distribution/Client/CmdConfigure.hs +++ b/Distribution/Client/CmdConfigure.hs @@ -16,7 +16,7 @@ import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import Distribution.Simple.Setup - ( HaddockFlags, fromFlagOrDefault ) + ( HaddockFlags, TestFlags, fromFlagOrDefault ) import Distribution.Verbosity ( normal ) @@ -27,11 +27,11 @@ import qualified Distribution.Client.Setup as Client configureCommand :: CommandUI (ConfigFlags, ConfigExFlags - ,InstallFlags, HaddockFlags) + ,InstallFlags, HaddockFlags, TestFlags) configureCommand = Client.installCommand { - commandName = "new-configure", + commandName = "v2-configure", commandSynopsis = "Add extra project configuration", - commandUsage = usageAlternatives "new-configure" [ "[FLAGS]" ], + commandUsage = usageAlternatives "v2-configure" [ "[FLAGS]" ], commandDescription = Just $ \_ -> wrapText $ "Adjust how the project is built by setting additional package flags " ++ "and other flags.\n\n" @@ -40,28 +40,28 @@ ++ "file (or '$project_file.local', if '--project-file' is specified) " ++ "which extends the configuration from the 'cabal.project' file " ++ "(if any). This combination is used as the project configuration for " - ++ "all other commands (such as 'new-build', 'new-repl' etc) though it " + ++ "all other commands (such as 'v2-build', 'v2-repl' etc) though it " ++ "can be extended/overridden on a per-command basis.\n\n" - ++ "The new-configure command also checks that the project configuration " + ++ "The v2-configure command also checks that the project configuration " ++ "will work. In particular it checks that there is a consistent set of " ++ "dependencies for the project as a whole.\n\n" - ++ "The 'cabal.project.local' file persists across 'new-clean' but is " - ++ "overwritten on the next use of the 'new-configure' command. The " + ++ "The 'cabal.project.local' file persists across 'v2-clean' but is " + ++ "overwritten on the next use of the 'v2-configure' command. The " ++ "intention is that the 'cabal.project' file should be kept in source " ++ "control but the 'cabal.project.local' should not.\n\n" - ++ "It is never necessary to use the 'new-configure' command. It is " + ++ "It is never necessary to use the 'v2-configure' command. It is " ++ "merely a convenience in cases where you do not want to specify flags " - ++ "to 'new-build' (and other commands) every time and yet do not want " + ++ "to 'v2-build' (and other commands) every time and yet do not want " ++ "to alter the 'cabal.project' persistently.", commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " new-configure --with-compiler ghc-7.10.3\n" + ++ " " ++ pname ++ " v2-configure --with-compiler ghc-7.10.3\n" ++ " Adjust the project configuration to use the given compiler\n" ++ " program and check the resulting configuration works.\n" - ++ " " ++ pname ++ " new-configure\n" + ++ " " ++ pname ++ " v2-configure\n" ++ " Reset the local configuration to empty and check the overall\n" ++ " project configuration works.\n\n" @@ -78,13 +78,13 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -configureAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +configureAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) -> [String] -> GlobalFlags -> IO () -configureAction (configFlags, configExFlags, installFlags, haddockFlags) +configureAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) _extraArgs globalFlags = do --TODO: deal with _extraArgs, since flags with wrong syntax end up there - baseCtx <- establishProjectBaseContext verbosity cliConfig + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand -- Write out the @cabal.project.local@ so it gets picked up by the -- planning phase. If old config exists, then print the contents @@ -121,5 +121,7 @@ verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags diff --git a/Distribution/Client/CmdErrorMessages.hs b/Distribution/Client/CmdErrorMessages.hs --- a/Distribution/Client/CmdErrorMessages.hs +++ b/Distribution/Client/CmdErrorMessages.hs @@ -15,9 +15,11 @@ ( packageId, PackageName, packageName ) import Distribution.Types.ComponentName ( showComponentName ) +import Distribution.Types.LibraryName + ( LibraryName(..) ) import Distribution.Solver.Types.OptionalStanza ( OptionalStanza(..) ) -import Distribution.Text +import Distribution.Deprecated.Text ( display ) import Data.Maybe (isNothing) @@ -165,8 +167,8 @@ targetSelectorFilter TargetComponentUnknown{} = Nothing renderComponentName :: PackageName -> ComponentName -> String -renderComponentName pkgname CLibName = "library " ++ display pkgname -renderComponentName _ (CSubLibName name) = "library " ++ display name +renderComponentName pkgname (CLibName LMainLibName) = "library " ++ display pkgname +renderComponentName _ (CLibName (LSubLibName name)) = "library " ++ display name renderComponentName _ (CFLibName name) = "foreign library " ++ display name renderComponentName _ (CExeName name) = "executable " ++ display name renderComponentName _ (CTestName name) = "test suite " ++ display name @@ -303,6 +305,8 @@ ++ plural (listPlural targets') " is " " are " ++ "not available because the solver did not find a plan that " ++ "included the " ++ renderOptionalStanza Plural stanza + ++ ". Force the solver to enable this for all packages by adding the " + ++ "line 'tests: True' to the 'cabal.project.local' file." (TargetNotBuildable, _) -> renderListCommaAnd [ "the " ++ showComponentName availableTargetComponentName diff --git a/Distribution/Client/CmdExec.hs b/Distribution/Client/CmdExec.hs --- a/Distribution/Client/CmdExec.hs +++ b/Distribution/Client/CmdExec.hs @@ -4,7 +4,7 @@ -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Implementation of the 'new-exec' command for running an arbitrary executable +-- Implementation of the 'v2-exec' command for running an arbitrary executable -- in an environment suited to the part of the store built for a project. ------------------------------------------------------------------------------- @@ -31,6 +31,7 @@ import Distribution.Client.ProjectOrchestration ( ProjectBuildContext(..) , runProjectPreBuildPhase + , CurrentCommand(..) , establishProjectBaseContext , distDirLayout , commandLineFlagsToProjectConfig @@ -74,6 +75,7 @@ , GhcImplInfo(supportsPkgEnvFiles) ) import Distribution.Simple.Setup ( HaddockFlags + , TestFlags , fromFlagOrDefault ) import Distribution.Simple.Utils @@ -94,24 +96,24 @@ import qualified Data.Set as S import qualified Data.Map as M -execCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +execCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) execCommand = CommandUI - { commandName = "new-exec" + { commandName = "v2-exec" , commandSynopsis = "Give a command access to the store." , commandUsage = \pname -> - "Usage: " ++ pname ++ " new-exec [FLAGS] [--] COMMAND [--] [ARGS]\n" + "Usage: " ++ pname ++ " v2-exec [FLAGS] [--] COMMAND [--] [ARGS]\n" , commandDescription = Just $ \pname -> wrapText $ "During development it is often useful to run build tasks and perform" ++ " one-off program executions to experiment with the behavior of build" ++ " tools. It is convenient to run these tools in the same way " ++ pname - ++ " itself would. The `" ++ pname ++ " new-exec` command provides a way to" + ++ " itself would. The `" ++ pname ++ " v2-exec` command provides a way to" ++ " do so.\n" ++ "\n" ++ "Compiler tools will be configured to see the same subset of the store" ++ " that builds would see. The PATH is modified to make all executables in" ++ " the dependency tree available (provided they have been built already)." ++ " Commands are also rewritten in the way cabal itself would. For" - ++ " example, `" ++ pname ++ " new-exec ghc` will consult the configuration" + ++ " example, `" ++ pname ++ " v2-exec ghc` will consult the configuration" ++ " to choose an appropriate version of ghc and to include any" ++ " ghc-specific flags requested." , commandNotes = Nothing @@ -119,12 +121,12 @@ , commandDefaultFlags = commandDefaultFlags Client.installCommand } -execAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +execAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) -> [String] -> GlobalFlags -> IO () -execAction (configFlags, configExFlags, installFlags, haddockFlags) +execAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) extraArgs globalFlags = do - baseCtx <- establishProjectBaseContext verbosity cliConfig + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand -- To set up the environment, we'd like to select the libraries in our -- dependency tree that we've already built. So first we set up an install @@ -193,7 +195,9 @@ verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags withOverrides env args program = program { programOverrideEnv = programOverrideEnv program ++ env , programDefaultArgs = programDefaultArgs program ++ args} diff --git a/Distribution/Client/CmdFreeze.hs b/Distribution/Client/CmdFreeze.hs --- a/Distribution/Client/CmdFreeze.hs +++ b/Distribution/Client/CmdFreeze.hs @@ -33,7 +33,7 @@ import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import Distribution.Simple.Setup - ( HaddockFlags, fromFlagOrDefault ) + ( HaddockFlags, TestFlags, fromFlagOrDefault ) import Distribution.Simple.Utils ( die', notice, wrapText ) import Distribution.Verbosity @@ -49,11 +49,11 @@ import qualified Distribution.Client.Setup as Client -freezeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +freezeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) freezeCommand = Client.installCommand { - commandName = "new-freeze", + commandName = "v2-freeze", commandSynopsis = "Freeze dependencies.", - commandUsage = usageAlternatives "new-freeze" [ "[FLAGS]" ], + commandUsage = usageAlternatives "v2-freeze" [ "[FLAGS]" ], commandDescription = Just $ \_ -> wrapText $ "The project configuration is frozen so that it will be reproducible " ++ "in future.\n\n" @@ -62,23 +62,23 @@ ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if " ++ "'--project-file' is specified). This file extends the configuration " ++ "from the 'cabal.project' file and thus is used as the project " - ++ "configuration for all other commands (such as 'new-build', " - ++ "'new-repl' etc).\n\n" + ++ "configuration for all other commands (such as 'v2-build', " + ++ "'v2-repl' etc).\n\n" ++ "The freeze file can be kept in source control. To make small " ++ "adjustments it may be edited manually, or to make bigger changes " ++ "you may wish to delete the file and re-freeze. For more control, " - ++ "one approach is to try variations using 'new-build --dry-run' with " + ++ "one approach is to try variations using 'v2-build --dry-run' with " ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have " - ++ "a satisfactory solution to freeze it using the 'new-freeze' command " + ++ "a satisfactory solution to freeze it using the 'v2-freeze' command " ++ "with the same set of flags.", commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " new-freeze\n" + ++ " " ++ pname ++ " v2-freeze\n" ++ " Freeze the configuration of the current project\n\n" - ++ " " ++ pname ++ " new-build --dry-run --constraint=\"aeson < 1\"\n" + ++ " " ++ pname ++ " v2-build --dry-run --constraint=\"aeson < 1\"\n" ++ " Check what a solution with the given constraints would look like\n" - ++ " " ++ pname ++ " new-freeze --constraint=\"aeson < 1\"\n" + ++ " " ++ pname ++ " v2-freeze --constraint=\"aeson < 1\"\n" ++ " Freeze a solution using the given constraints\n\n" ++ "Note: this command is part of the new project-based system (aka " @@ -99,9 +99,9 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -freezeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +freezeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) -> [String] -> GlobalFlags -> IO () -freezeAction (configFlags, configExFlags, installFlags, haddockFlags) +freezeAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) extraArgs globalFlags = do unless (null extraArgs) $ @@ -113,7 +113,7 @@ cabalDirLayout, projectConfig, localPackages - } <- establishProjectBaseContext verbosity cliConfig + } <- establishProjectBaseContext verbosity cliConfig OtherCommand (_, elaboratedPlan, _) <- rebuildInstallPlan verbosity @@ -130,7 +130,9 @@ verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags diff --git a/Distribution/Client/CmdHaddock.hs b/Distribution/Client/CmdHaddock.hs --- a/Distribution/Client/CmdHaddock.hs +++ b/Distribution/Client/CmdHaddock.hs @@ -20,7 +20,7 @@ ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags(..), fromFlagOrDefault ) + ( HaddockFlags(..), TestFlags, fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Verbosity @@ -32,11 +32,11 @@ haddockCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags - ,HaddockFlags) + ,HaddockFlags, TestFlags) haddockCommand = Client.installCommand { - commandName = "new-haddock", + commandName = "v2-haddock", commandSynopsis = "Build Haddock documentation", - commandUsage = usageAlternatives "new-haddock" [ "[FLAGS] TARGET" ], + commandUsage = usageAlternatives "v2-haddock" [ "[FLAGS] TARGET" ], commandDescription = Just $ \_ -> wrapText $ "Build Haddock documentation for the specified packages within the " ++ "project.\n\n" @@ -56,7 +56,7 @@ ++ "'cabal.project.local' and other files.", commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " new-haddock pkgname" + ++ " " ++ pname ++ " v2-haddock pkgname" ++ " Build documentation for the package named pkgname\n\n" ++ cmdCommonHelpTextNewBuildBeta @@ -69,12 +69,12 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -haddockAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +haddockAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) -> [String] -> GlobalFlags -> IO () -haddockAction (configFlags, configExFlags, installFlags, haddockFlags) +haddockAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) targetStrings globalFlags = do - baseCtx <- establishProjectBaseContext verbosity cliConfig + baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand targetSelectors <- either (reportTargetSelectorProblems verbosity) return =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings @@ -111,7 +111,9 @@ verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags -- | This defines what a 'TargetSelector' means for the @haddock@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, @@ -153,7 +155,7 @@ isRequested _ LibKind = True -- isRequested _ SubLibKind = True --TODO: what about sublibs? - -- TODO/HACK, we encode some defaults here as new-haddock's logic; + -- TODO/HACK, we encode some defaults here as v2-haddock's logic; -- make sure this matches the defaults applied in -- "Distribution.Client.ProjectPlanning"; this may need more work -- to be done properly diff --git a/Distribution/Client/CmdInstall.hs b/Distribution/Client/CmdInstall.hs --- a/Distribution/Client/CmdInstall.hs +++ b/Distribution/Client/CmdInstall.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: build -- @@ -20,14 +20,19 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Compat.Directory + ( doesPathExist ) import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.CmdSdist +import Distribution.Client.CmdInstall.ClientInstallFlags + import Distribution.Client.Setup ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..) - , configureExOptions, installOptions, liftOptions ) + , configureExOptions, haddockOptions, installOptions, testOptions + , configureOptions, liftOptions ) import Distribution.Solver.Types.ConstraintSource ( ConstraintSource(..) ) import Distribution.Client.Types @@ -46,11 +51,13 @@ , projectConfigDistDir, projectConfigConfigFile ) import Distribution.Simple.Program.Db ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb - , modifyProgramSearchPath ) + , modifyProgramSearchPath, ProgramDb ) +import Distribution.Simple.BuildPaths + ( exeExtension ) import Distribution.Simple.Program.Find ( ProgramSearchPathEntry(..) ) import Distribution.Client.Config - ( getCabalDir ) + ( getCabalDir, loadConfig, SavedConfig(..) ) import qualified Distribution.Simple.PackageIndex as PI import Distribution.Solver.Types.PackageIndex ( lookupPackageName, searchByName ) @@ -67,38 +74,40 @@ import Distribution.Client.ProjectConfig ( readGlobalConfig, projectConfigWithBuilderRepoContext , resolveBuildTimeSettings, withProjectOrGlobalConfig ) +import Distribution.Client.ProjectPlanning + ( storePackageInstallDirs' ) +import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Client.DistDirLayout ( defaultDistDirLayout, DistDirLayout(..), mkCabalDirLayout , ProjectRoot(ProjectRootImplicit) - , storePackageDirectory, cabalStoreDirLayout + , cabalStoreDirLayout , CabalDirLayout(..), StoreDirLayout(..) ) import Distribution.Client.RebuildMonad ( runRebuild ) import Distribution.Client.InstallSymlink ( OverwritePolicy(..), symlinkBinary ) import Distribution.Simple.Setup - ( Flag(..), HaddockFlags, fromFlagOrDefault, flagToMaybe, toFlag - , trueArg, configureOptions, haddockOptions, flagToList ) + ( Flag(..), HaddockFlags, TestFlags, fromFlagOrDefault, flagToMaybe ) import Distribution.Solver.Types.SourcePackage ( SourcePackage(..) ) -import Distribution.ReadE - ( ReadE(..), succeedReadE ) import Distribution.Simple.Command - ( CommandUI(..), ShowOrParseArgs(..), OptionField(..) - , option, usageAlternatives, reqArg ) + ( CommandUI(..), OptionField(..), usageAlternatives ) import Distribution.Simple.Configure ( configCompilerEx ) import Distribution.Simple.Compiler - ( Compiler(..), CompilerId(..), CompilerFlavor(..) ) + ( Compiler(..), CompilerId(..), CompilerFlavor(..) + , PackageDBStack ) import Distribution.Simple.GHC ( ghcPlatformAndVersionString , GhcImplInfo(..), getImplInfo , GhcEnvironmentFileEntry(..) , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc ) +import Distribution.System + ( Platform ) import Distribution.Types.UnitId ( UnitId ) import Distribution.Types.UnqualComponentName - ( UnqualComponentName, unUnqualComponentName ) + ( UnqualComponentName, unUnqualComponentName, mkUnqualComponentName ) import Distribution.Verbosity ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils @@ -107,7 +116,7 @@ , ordNub ) import Distribution.Utils.Generic ( writeFileAtomic ) -import Distribution.Text +import Distribution.Deprecated.Text ( simpleParse ) import Distribution.Pretty ( prettyShow ) @@ -118,7 +127,7 @@ ( mapM, mapM_ ) import qualified Data.ByteString.Lazy.Char8 as BS import Data.Either - ( partitionEithers, isLeft ) + ( partitionEithers ) import Data.Ord ( comparing, Down(..) ) import qualified Data.Map as Map @@ -126,62 +135,24 @@ ( fromNubList ) import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing - , getTemporaryDirectory, makeAbsolute, doesDirectoryExist ) + , getTemporaryDirectory, makeAbsolute, doesDirectoryExist + , removeFile, removeDirectory, copyFile ) import System.FilePath - ( (), takeDirectory, takeBaseName ) + ( (), (<.>), takeDirectory, takeBaseName ) -data NewInstallFlags = NewInstallFlags - { ninstInstallLibs :: Flag Bool - , ninstEnvironmentPath :: Flag FilePath - , ninstOverwritePolicy :: Flag OverwritePolicy - } -defaultNewInstallFlags :: NewInstallFlags -defaultNewInstallFlags = NewInstallFlags - { ninstInstallLibs = toFlag False - , ninstEnvironmentPath = mempty - , ninstOverwritePolicy = toFlag NeverOverwrite - } - -newInstallOptions :: ShowOrParseArgs -> [OptionField NewInstallFlags] -newInstallOptions _ = - [ option [] ["lib"] - "Install libraries rather than executables from the target package." - ninstInstallLibs (\v flags -> flags { ninstInstallLibs = v }) - trueArg - , option [] ["package-env", "env"] - "Set the environment file that may be modified." - ninstEnvironmentPath (\pf flags -> flags { ninstEnvironmentPath = pf }) - (reqArg "ENV" (succeedReadE Flag) flagToList) - , option [] ["overwrite-policy"] - "How to handle already existing symlinks." - ninstOverwritePolicy (\v flags -> flags { ninstOverwritePolicy = v }) - $ reqArg - "always|never" - readOverwritePolicyFlag - showOverwritePolicyFlag - ] - where - readOverwritePolicyFlag = ReadE $ \case - "always" -> Right $ Flag AlwaysOverwrite - "never" -> Right $ Flag NeverOverwrite - policy -> Left $ "'" <> policy <> "' isn't a valid overwrite policy" - showOverwritePolicyFlag (Flag AlwaysOverwrite) = ["always"] - showOverwritePolicyFlag (Flag NeverOverwrite) = ["never"] - showOverwritePolicyFlag NoFlag = [] - installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags - , HaddockFlags, NewInstallFlags + , HaddockFlags, TestFlags, ClientInstallFlags ) installCommand = CommandUI - { commandName = "new-install" + { commandName = "v2-install" , commandSynopsis = "Install packages." , commandUsage = usageAlternatives - "new-install" [ "[TARGETS] [FLAGS]" ] + "v2-install" [ "[TARGETS] [FLAGS]" ] , commandDescription = Just $ \_ -> wrapText $ "Installs one or more packages. This is done by installing them " - ++ "in the store and symlinking the executables in the directory " - ++ "specified by the --symlink-bindir flag (`~/.cabal/bin/` by default). " + ++ "in the store and symlinking/copying the executables in the directory " + ++ "specified by the --installdir flag (`~/.cabal/bin/` by default). " ++ "If you want the installed executables to be available globally, " ++ "make sure that the PATH environment variable contains that directory. " ++ "\n\n" @@ -190,12 +161,12 @@ ++ "the previously installed libraries. This is currently not implemented." , commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " new-install\n" + ++ " " ++ pname ++ " v2-install\n" ++ " Install the package in the current directory\n" - ++ " " ++ pname ++ " new-install pkgname\n" + ++ " " ++ pname ++ " v2-install pkgname\n" ++ " Install the package named pkgname" ++ " (fetching it from hackage if necessary)\n" - ++ " " ++ pname ++ " new-install ./pkgfoo\n" + ++ " " ++ pname ++ " v2-install ./pkgfoo\n" ++ " Install the package in the ./pkgfoo directory\n" ++ cmdCommonHelpTextNewBuildBeta @@ -209,9 +180,10 @@ . optionName) $ configureOptions showOrParseArgs) ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) ++ liftOptions get3 set3 - -- hide "target-package-db" flag from the + -- hide "target-package-db" and "symlink-bindir" flags from the -- install options. - (filter ((`notElem` ["target-package-db"]) + -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags + (filter ((`notElem` ["target-package-db", "symlink-bindir"]) . optionName) $ installOptions showOrParseArgs) ++ liftOptions get4 set4 @@ -220,15 +192,17 @@ (filter ((`notElem` ["v", "verbose", "builddir"]) . optionName) $ haddockOptions showOrParseArgs) - ++ liftOptions get5 set5 (newInstallOptions showOrParseArgs) - , commandDefaultFlags = (mempty, mempty, mempty, mempty, defaultNewInstallFlags) + ++ liftOptions get5 set5 (testOptions showOrParseArgs) + ++ liftOptions get6 set6 (clientInstallOptions showOrParseArgs) + , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, defaultClientInstallFlags) } where - get1 (a,_,_,_,_) = a; set1 a (_,b,c,d,e) = (a,b,c,d,e) - get2 (_,b,_,_,_) = b; set2 b (a,_,c,d,e) = (a,b,c,d,e) - get3 (_,_,c,_,_) = c; set3 c (a,b,_,d,e) = (a,b,c,d,e) - get4 (_,_,_,d,_) = d; set4 d (a,b,c,_,e) = (a,b,c,d,e) - get5 (_,_,_,_,e) = e; set5 e (a,b,c,d,_) = (a,b,c,d,e) + get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f) + get2 (_,b,_,_,_,_) = b; set2 b (a,_,c,d,e,f) = (a,b,c,d,e,f) + get3 (_,_,c,_,_,_) = c; set3 c (a,b,_,d,e,f) = (a,b,c,d,e,f) + get4 (_,_,_,d,_,_) = d; set4 d (a,b,c,_,e,f) = (a,b,c,d,e,f) + get5 (_,_,_,_,e,_) = e; set5 e (a,b,c,d,_,f) = (a,b,c,d,e,f) + get6 (_,_,_,_,_,f) = f; set6 f (a,b,c,d,e,_) = (a,b,c,d,e,f) -- | The @install@ command actually serves four different needs. It installs: @@ -237,20 +211,20 @@ -- install command, except that now conflicts between separate runs of the -- command are impossible thanks to the store. -- Exes are installed in the store like a normal dependency, then they are --- symlinked uin the directory specified by --symlink-bindir. +-- symlinked/copied in the directory specified by --installdir. -- To do this we need a dummy projectBaseContext containing the targets as -- estra packages and using a temporary dist directory. -- * libraries -- Libraries install through a similar process, but using GHC environment --- files instead of symlinks. This means that 'new-install'ing libraries +-- files instead of symlinks. This means that 'v2-install'ing libraries -- only works on GHC >= 8.0. -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, NewInstallFlags) +installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, ClientInstallFlags) -> [String] -> GlobalFlags -> IO () -installAction (configFlags, configExFlags, installFlags, haddockFlags, newInstallFlags) +installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags, clientInstallFlags') targetStrings globalFlags = do -- We never try to build tests/benchmarks for remote packages. -- So we set them as disabled by default and error if they are explicitly @@ -262,17 +236,29 @@ die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't " ++ "be enabled in a remote package" + -- We cannot use establishDummyProjectBaseContext to get these flags, since + -- it requires one of them as an argument. Normal establishProjectBaseContext + -- does not, and this is why this is done only for the install command + clientInstallFlags <- do + let configFileFlag = globalConfigFile globalFlags + savedConfig <- loadConfig verbosity configFileFlag + pure $ savedClientInstallFlags savedConfig `mappend` clientInstallFlags' + let + installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags) + targetFilter = if installLibs then Just LibKind else Just ExeKind + targetStrings' = if null targetStrings then ["."] else targetStrings + withProject = do let verbosity' = lessVerbose verbosity -- First, we need to learn about what's available to be installed. - localBaseCtx <- establishProjectBaseContext verbosity' cliConfig + localBaseCtx <- establishProjectBaseContext verbosity' cliConfig InstallCommand let localDistDirLayout = distDirLayout localBaseCtx pkgDb <- projectConfigWithBuilderRepoContext verbosity' (buildSettings localBaseCtx) (getSourcePackages verbosity) let - (targetStrings', packageIds) = partitionEithers . flip fmap targetStrings $ + (targetStrings'', packageIds) = partitionEithers . flip fmap targetStrings' $ \str -> case simpleParse str of Just (pkgId :: PackageId) | pkgVersion pkgId /= nullVersion -> Right pkgId @@ -282,13 +268,13 @@ | pkgVersion == nullVersion -> NamedPackage pkgName [] | otherwise -> NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)] - packageTargets = flip TargetPackageNamed Nothing . pkgName <$> packageIds + packageTargets = flip TargetPackageNamed targetFilter . pkgName <$> packageIds if null targetStrings' then return (packageSpecifiers, packageTargets, projectConfig localBaseCtx) else do targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages localBaseCtx) Nothing targetStrings' + =<< readTargetSelectors (localPackages localBaseCtx) Nothing targetStrings'' (specs, selectors) <- withInstallPlan verbosity' localBaseCtx $ \elaboratedPlan _ -> do -- Split into known targets and hackage packages. @@ -321,7 +307,7 @@ , unlines (("- " ++) . unPackageName . fst <$> xs) ] _ -> return () - + when (not . null $ errs') $ reportTargetProblems verbosity errs' let @@ -349,14 +335,14 @@ sdistize (SpecificSourcePackage spkg@SourcePackage{..}) = SpecificSourcePackage spkg' where - sdistPath = distSdistFile localDistDirLayout packageInfoId TargzFormat + sdistPath = distSdistFile localDistDirLayout packageInfoId spkg' = spkg { packageSource = LocalTarballPackage sdistPath } sdistize named = named local = sdistize <$> localPackages localBaseCtx gatherTargets :: UnitId -> TargetSelector - gatherTargets targetId = TargetPackageNamed pkgName Nothing + gatherTargets targetId = TargetPackageNamed pkgName targetFilter where Just targetUnit = Map.lookup targetId planMap PackageIdentifier{..} = packageId targetUnit @@ -366,15 +352,15 @@ hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage] hackagePkgs = flip NamedPackage [] <$> hackageNames hackageTargets :: [TargetSelector] - hackageTargets = flip TargetPackageNamed Nothing <$> hackageNames + hackageTargets = flip TargetPackageNamed targetFilter <$> hackageNames createDirectoryIfMissing True (distSdistDirectory localDistDirLayout) unless (Map.null targets) $ mapM_ (\(SpecificSourcePackage pkg) -> packageToSdist verbosity - (distProjectRootDirectory localDistDirLayout) (Archive TargzFormat) - (distSdistFile localDistDirLayout (packageId pkg) TargzFormat) pkg + (distProjectRootDirectory localDistDirLayout) TarGzArchive + (distSdistFile localDistDirLayout (packageId pkg)) pkg ) (localPackages localBaseCtx) if null targets @@ -388,10 +374,10 @@ parsePkg pkgName | Just (pkg :: PackageId) <- simpleParse pkgName = return pkg | otherwise = die' verbosity ("Invalid package ID: " ++ pkgName) - packageIds <- mapM parsePkg targetStrings - + packageIds <- mapM parsePkg targetStrings' + cabalDir <- getCabalDir - let + let projectConfig = globalConfig <> cliConfig ProjectConfigBuildOnly { @@ -411,10 +397,10 @@ projectConfig SourcePackageDb { packageIndex } <- projectConfigWithBuilderRepoContext - verbosity buildSettings + verbosity buildSettings (getSourcePackages verbosity) - for_ targetStrings $ \case + for_ targetStrings' $ \case name | null (lookupPackageName packageIndex (mkPackageName name)) , xs@(_:_) <- searchByName packageIndex name -> @@ -456,7 +442,8 @@ hcPath = flagToMaybe projectConfigHcPath hcPkg = flagToMaybe projectConfigHcPkg - progDb = + -- ProgramDb with directly user specified paths + preProgDb = userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) . modifyProgramSearchPath @@ -464,9 +451,10 @@ | dir <- fromNubList packageConfigProgramPathExtra ]) $ defaultProgramDb + -- progDb is a program database with compiler tools configured properly (compiler@Compiler { compilerId = - compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb') <- - configCompilerEx hcFlavor hcPath hcPkg progDb verbosity + compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb) <- + configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity let globalEnv name = @@ -481,7 +469,7 @@ GhcEnvFilePackageId _ -> True _ -> False - envFile <- case flagToMaybe (ninstEnvironmentPath newInstallFlags) of + envFile <- case flagToMaybe (cinstEnvironmentPath clientInstallFlags) of Just spec -- Is spec a bare word without any "pathy" content, then it refers to -- a named global environment. @@ -513,7 +501,7 @@ cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir packageDbs = storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId - installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb' + installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb let (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex envEntries @@ -531,6 +519,7 @@ config tmpDir (envSpecs ++ specs) + InstallCommand buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -561,75 +550,103 @@ printPlan verbosity baseCtx buildCtx buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - -- Temporary fix for #5641 - when (any isLeft buildOutcomes) $ - warn verbosity $ "Some package(s) failed to build. " - <> "Try rerunning with -j1 if you can't see the error." runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + -- Now that we built everything we can do the installation part. + -- First, figure out if / what parts we want to install: let dryRun = buildSettingDryRun $ buildSettings baseCtx - mkPkgBinDir = ( "bin") . - storePackageDirectory - (cabalStoreDirLayout $ cabalDirLayout baseCtx) - compilerId - installLibs = fromFlagOrDefault False (ninstInstallLibs newInstallFlags) - when (not installLibs && not dryRun) $ do - -- If there are exes, symlink them - let symlinkBindirUnknown = - "symlink-bindir is not defined. Set it in your cabal config file " - ++ "or use --symlink-bindir=" - symlinkBindir <- fromFlagOrDefault (die' verbosity symlinkBindirUnknown) - $ fmap makeAbsolute - $ projectConfigSymlinkBinDir - $ projectConfigBuildOnly - $ projectConfig $ baseCtx - createDirectoryIfMissingVerbose verbosity False symlinkBindir - warnIfNoExes verbosity buildCtx - let - doSymlink = symlinkBuiltPackage - verbosity - overwritePolicy - mkPkgBinDir symlinkBindir - in traverse_ doSymlink $ Map.toList $ targetsMap buildCtx - - when (installLibs && not dryRun) $ - if supportsPkgEnvFiles - then do - -- Why do we get it again? If we updated a globalPackage then we need - -- the new version. - installedIndex' <- getInstalledPackages verbosity compiler packageDbs progDb' - let - getLatest = fmap (head . snd) . take 1 . sortBy (comparing (Down . fst)) - . PI.lookupPackageName installedIndex' - globalLatest = concat (getLatest <$> globalPackages) - - baseEntries = - GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs - globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest - pkgEntries = ordNub $ - globalEntries - ++ envEntries' - ++ entriesForLibraryComponents (targetsMap buildCtx) - contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries) - createDirectoryIfMissing True (takeDirectory envFile) - writeFileAtomic envFile (BS.pack contents') - else - warn verbosity $ - "The current compiler doesn't support safely installing libraries, " - ++ "so only executables will be available. (Library installation is " - ++ "supported on GHC 8.0+ only)" + -- Then, install! + when (not dryRun) $ + if installLibs + then installLibraries verbosity buildCtx compiler packageDbs progDb envFile envEntries' + else installExes verbosity baseCtx buildCtx platform compiler clientInstallFlags where configFlags' = disableTestsBenchsByDefault configFlags verbosity = fromFlagOrDefault normal (configVerbosity configFlags') cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags' configExFlags - installFlags haddockFlags + installFlags clientInstallFlags' + haddockFlags testFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) + +-- | Install any built exe by symlinking/copying it +-- we don't use BuildOutcomes because we also need the component names +installExes :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> Platform + -> Compiler + -> ClientInstallFlags + -> IO () +installExes verbosity baseCtx buildCtx platform compiler + clientInstallFlags = do + let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx + let mkUnitBinDir :: UnitId -> FilePath + mkUnitBinDir = InstallDirs.bindir . + storePackageInstallDirs' + storeDirLayout + (compilerId compiler) + mkExeName :: UnqualComponentName -> FilePath + mkExeName exe = unUnqualComponentName exe <.> exeExtension platform + installdirUnknown = + "installdir is not defined. Set it in your cabal config file " + ++ "or use --installdir=" + installdir <- fromFlagOrDefault (die' verbosity installdirUnknown) + $ pure <$> cinstInstalldir clientInstallFlags + createDirectoryIfMissingVerbose verbosity False installdir + warnIfNoExes verbosity buildCtx + let + doInstall = installUnitExes + verbosity + overwritePolicy + mkUnitBinDir mkExeName + installdir installMethod + in traverse_ doInstall $ Map.toList $ targetsMap buildCtx + where overwritePolicy = fromFlagOrDefault NeverOverwrite - $ ninstOverwritePolicy newInstallFlags + $ cinstOverwritePolicy clientInstallFlags + installMethod = fromFlagOrDefault InstallMethodSymlink + $ cinstInstallMethod clientInstallFlags +-- | Install any built library by adding it to the default ghc environment +installLibraries :: Verbosity + -> ProjectBuildContext + -> Compiler + -> PackageDBStack + -> ProgramDb + -> FilePath -- ^ Environment file + -> [GhcEnvironmentFileEntry] + -> IO () +installLibraries verbosity buildCtx compiler + packageDbs programDb envFile envEntries = do + -- Why do we get it again? If we updated a globalPackage then we need + -- the new version. + installedIndex <- getInstalledPackages verbosity compiler packageDbs programDb + if supportsPkgEnvFiles $ getImplInfo compiler + then do + let + getLatest = fmap (head . snd) . take 1 . sortBy (comparing (Down . fst)) + . PI.lookupPackageName installedIndex + globalLatest = concat (getLatest <$> globalPackages) + + baseEntries = + GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs + globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest + pkgEntries = ordNub $ + globalEntries + ++ envEntries + ++ entriesForLibraryComponents (targetsMap buildCtx) + contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries) + createDirectoryIfMissing True (takeDirectory envFile) + writeFileAtomic envFile (BS.pack contents') + else + warn verbosity $ + "The current compiler doesn't support safely installing libraries, " + ++ "so only executables will be available. (Library installation is " + ++ "supported on GHC 8.0+ only)" + warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO () warnIfNoExes verbosity buildCtx = when noExes $ @@ -675,58 +692,87 @@ configFlags { configTests = Flag False <> configTests configFlags , configBenchmarks = Flag False <> configBenchmarks configFlags } --- | Symlink every exe from a package from the store to a given location -symlinkBuiltPackage :: Verbosity - -> OverwritePolicy -- ^ Whether to overwrite existing files - -> (UnitId -> FilePath) -- ^ A function to get an UnitId's - -- store directory - -> FilePath -- ^ Where to put the symlink - -> ( UnitId - , [(ComponentTarget, [TargetSelector])] ) - -> IO () -symlinkBuiltPackage verbosity overwritePolicy - mkSourceBinDir destDir - (pkg, components) = - traverse_ symlinkAndWarn exes +-- | Symlink/copy every exe from a package from the store to a given location +installUnitExes :: Verbosity + -> OverwritePolicy -- ^ Whether to overwrite existing files + -> (UnitId -> FilePath) -- ^ A function to get an UnitId's + -- store directory + -> (UnqualComponentName -> FilePath) -- ^ A function to get + -- ^ an exe's filename + -> FilePath + -> InstallMethod + -> ( UnitId + , [(ComponentTarget, [TargetSelector])] ) + -> IO () +installUnitExes verbosity overwritePolicy + mkSourceBinDir mkExeName + installdir installMethod + (unit, components) = + traverse_ installAndWarn exes where exes = catMaybes $ (exeMaybe . fst) <$> components exeMaybe (ComponentTarget (CExeName exe) _) = Just exe exeMaybe _ = Nothing - symlinkAndWarn exe = do - success <- symlinkBuiltExe + installAndWarn exe = do + success <- installBuiltExe verbosity overwritePolicy - (mkSourceBinDir pkg) destDir exe + (mkSourceBinDir unit) (mkExeName exe) + installdir installMethod let errorMessage = case overwritePolicy of NeverOverwrite -> - "Path '" <> (destDir prettyShow exe) <> "' already exists. " + "Path '" <> (installdir prettyShow exe) <> "' already exists. " <> "Use --overwrite-policy=always to overwrite." -- This shouldn't even be possible, but we keep it in case - -- symlinking logic changes - AlwaysOverwrite -> "Symlinking '" <> prettyShow exe <> "' failed." + -- symlinking/copying logic changes + AlwaysOverwrite -> case installMethod of + InstallMethodSymlink -> "Symlinking" + InstallMethodCopy -> "Copying" + <> " '" <> prettyShow exe <> "' failed." unless success $ die' verbosity errorMessage --- | Symlink a specific exe. -symlinkBuiltExe :: Verbosity -> OverwritePolicy - -> FilePath -> FilePath - -> UnqualComponentName - -> IO Bool -symlinkBuiltExe verbosity overwritePolicy sourceDir destDir exe = do - notice verbosity $ "Symlinking '" <> prettyShow exe <> "'" +-- | Install a specific exe. +installBuiltExe :: Verbosity -> OverwritePolicy + -> FilePath -- ^ The directory where the built exe is located + -> FilePath -- ^ The exe's filename + -> FilePath -- ^ the directory where it should be installed + -> InstallMethod + -> IO Bool -- ^ Whether the installation was successful +installBuiltExe verbosity overwritePolicy + sourceDir exeName + installdir InstallMethodSymlink = do + notice verbosity $ "Symlinking '" <> exeName <> "'" symlinkBinary overwritePolicy - destDir + installdir sourceDir - exe - $ unUnqualComponentName exe + (mkUnqualComponentName exeName) + exeName +installBuiltExe verbosity overwritePolicy + sourceDir exeName + installdir InstallMethodCopy = do + notice verbosity $ "Copying '" <> exeName <> "'" + exists <- doesPathExist destination + case (exists, overwritePolicy) of + (True , NeverOverwrite ) -> pure False + (True , AlwaysOverwrite) -> remove >> copy + (False, _ ) -> copy + where + source = sourceDir exeName + destination = installdir exeName + remove = do + isDir <- doesDirectoryExist destination + if isDir + then removeDirectory destination + else removeFile destination + copy = copyFile source destination >> pure True -- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries. entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry] entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) [] where hasLib :: (ComponentTarget, [TargetSelector]) -> Bool - hasLib (ComponentTarget CLibName _, _) = True - hasLib (ComponentTarget (CSubLibName _) _, _) = True - hasLib _ = False + hasLib (ComponentTarget (CLibName _) _, _) = True + hasLib _ = False go :: UnitId -> [(ComponentTarget, [TargetSelector])] -> [GhcEnvironmentFileEntry] go unitId targets @@ -742,9 +788,10 @@ -- ^ Where to put the dist directory -> [PackageSpecifier UnresolvedSourcePackage] -- ^ The packages to be included in the project + -> CurrentCommand -> IO ProjectBaseContext -establishDummyProjectBaseContext verbosity cliConfig tmpDir localPackages = do - +establishDummyProjectBaseContext verbosity cliConfig tmpDir + localPackages currentCommand = do cabalDir <- getCabalDir -- Create the dist directories @@ -779,7 +826,8 @@ cabalDirLayout, projectConfig, localPackages, - buildSettings + buildSettings, + currentCommand } where mdistDirectory = flagToMaybe diff --git a/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/Distribution/Client/CmdInstall/ClientInstallFlags.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/CmdInstall/ClientInstallFlags.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +module Distribution.Client.CmdInstall.ClientInstallFlags +( InstallMethod(..) +, ClientInstallFlags(..) +, defaultClientInstallFlags +, clientInstallOptions +) where + +import Distribution.Client.Compat.Prelude + +import Distribution.ReadE + ( ReadE(..), succeedReadE ) +import Distribution.Simple.Command + ( ShowOrParseArgs(..), OptionField(..), option, reqArg ) +import Distribution.Simple.Setup + ( Flag(..), trueArg, flagToList, toFlag ) + +import Distribution.Client.InstallSymlink + ( OverwritePolicy(..) ) + + +data InstallMethod = InstallMethodCopy + | InstallMethodSymlink + deriving (Eq, Show, Generic, Bounded, Enum) + +instance Binary InstallMethod + +data ClientInstallFlags = ClientInstallFlags + { cinstInstallLibs :: Flag Bool + , cinstEnvironmentPath :: Flag FilePath + , cinstOverwritePolicy :: Flag OverwritePolicy + , cinstInstallMethod :: Flag InstallMethod + , cinstInstalldir :: Flag FilePath + } deriving (Eq, Show, Generic) + +instance Monoid ClientInstallFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ClientInstallFlags where + (<>) = gmappend + +instance Binary ClientInstallFlags + +defaultClientInstallFlags :: ClientInstallFlags +defaultClientInstallFlags = ClientInstallFlags + { cinstInstallLibs = toFlag False + , cinstEnvironmentPath = mempty + , cinstOverwritePolicy = mempty + , cinstInstallMethod = mempty + , cinstInstalldir = mempty + } + +clientInstallOptions :: ShowOrParseArgs -> [OptionField ClientInstallFlags] +clientInstallOptions _ = + [ option [] ["lib"] + "Install libraries rather than executables from the target package." + cinstInstallLibs (\v flags -> flags { cinstInstallLibs = v }) + trueArg + , option [] ["package-env", "env"] + "Set the environment file that may be modified." + cinstEnvironmentPath (\pf flags -> flags { cinstEnvironmentPath = pf }) + (reqArg "ENV" (succeedReadE Flag) flagToList) + , option [] ["overwrite-policy"] + "How to handle already existing symlinks." + cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v }) + $ reqArg + "always|never" + readOverwritePolicyFlag + showOverwritePolicyFlag + , option [] ["install-method"] + "How to install the executables." + cinstInstallMethod (\v flags -> flags { cinstInstallMethod = v }) + $ reqArg + "copy|symlink" + readInstallMethodFlag + showInstallMethodFlag + , option [] ["installdir"] + "Where to install (by symlinking or copying) the executables in." + cinstInstalldir (\v flags -> flags { cinstInstalldir = v }) + $ reqArg "DIR" (succeedReadE Flag) flagToList + ] + +readOverwritePolicyFlag :: ReadE (Flag OverwritePolicy) +readOverwritePolicyFlag = ReadE $ \case + "always" -> Right $ Flag AlwaysOverwrite + "never" -> Right $ Flag NeverOverwrite + policy -> Left $ "'" <> policy <> "' isn't a valid overwrite policy" + +showOverwritePolicyFlag :: Flag OverwritePolicy -> [String] +showOverwritePolicyFlag (Flag AlwaysOverwrite) = ["always"] +showOverwritePolicyFlag (Flag NeverOverwrite) = ["never"] +showOverwritePolicyFlag NoFlag = [] + +readInstallMethodFlag :: ReadE (Flag InstallMethod) +readInstallMethodFlag = ReadE $ \case + "copy" -> Right $ Flag InstallMethodCopy + "symlink" -> Right $ Flag InstallMethodSymlink + method -> Left $ "'" <> method <> "' isn't a valid install-method" + +showInstallMethodFlag :: Flag InstallMethod -> [String] +showInstallMethodFlag (Flag InstallMethodCopy) = ["copy"] +showInstallMethodFlag (Flag InstallMethodSymlink) = ["symlink"] +showInstallMethodFlag NoFlag = [] + diff --git a/Distribution/Client/CmdLegacy.hs b/Distribution/Client/CmdLegacy.hs --- a/Distribution/Client/CmdLegacy.hs +++ b/Distribution/Client/CmdLegacy.hs @@ -15,7 +15,7 @@ import qualified Distribution.Simple.Setup as Setup import Distribution.Simple.Command import Distribution.Simple.Utils - ( warn, wrapText ) + ( wrapText ) import Distribution.Verbosity ( Verbosity, normal ) @@ -24,28 +24,20 @@ import qualified Data.Text as T -- Tweaked versions of code from Main. -regularCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> Bool -> CommandSpec (globals -> IO action) -regularCmd ui action shouldWarn = - CommandSpec ui ((flip commandAddAction) (\flags extra globals -> showWarning flags >> action flags extra globals)) NormalCommand - where - showWarning flags = if shouldWarn - then warn (verbosity flags) (deprecationNote (commandName ui) ++ "\n") - else return () +regularCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> CommandSpec (globals -> IO action) +regularCmd ui action = + CommandSpec ui ((flip commandAddAction) (\flags extra globals -> action flags extra globals)) NormalCommand -wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Bool -> CommandSpec (Client.GlobalFlags -> IO ()) -wrapperCmd ui verbosity' distPref shouldWarn = - CommandSpec ui (\ui' -> wrapperAction ui' verbosity' distPref shouldWarn) NormalCommand +wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> CommandSpec (Client.GlobalFlags -> IO ()) +wrapperCmd ui verbosity' distPref = + CommandSpec ui (\ui' -> wrapperAction ui' verbosity' distPref) NormalCommand -wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Bool -> Command (Client.GlobalFlags -> IO ()) -wrapperAction command verbosityFlag distPrefFlag shouldWarn = +wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Command (Client.GlobalFlags -> IO ()) +wrapperAction command verbosityFlag distPrefFlag = commandAddAction command { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do let verbosity' = Setup.fromFlagOrDefault normal (verbosityFlag flags) - if shouldWarn - then warn verbosity' (deprecationNote (commandName command) ++ "\n") - else return () - load <- try (loadConfigOrSandboxConfig verbosity' globalFlags) let config = either (\(SomeException _) -> mempty) snd load distPref <- findSavedDistPref config (distPrefFlag flags) @@ -73,6 +65,9 @@ instance (HasVerbosity a) => HasVerbosity (a, b, c, d) where verbosity (a, _, _, _) = verbosity a +instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e) where + verbosity (a, _, _, _, _) = verbosity a + instance HasVerbosity Setup.BuildFlags where verbosity = verbosity . Setup.buildVerbosity @@ -108,17 +103,6 @@ -- -deprecationNote :: String -> String -deprecationNote cmd = wrapText $ - "The " ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++ - - "Please switch to using either the new project style and the new-" ++ cmd ++ - " command or the legacy v1-" ++ cmd ++ " alias as new-style projects will" ++ - " become the default in the next version of cabal-install. Please file a" ++ - " bug if you cannot replicate a working v1- use case with the new-style commands.\n\n" ++ - - "For more information, see: https://wiki.haskell.org/Cabal/NewBuild\n" - legacyNote :: String -> String legacyNote cmd = wrapText $ "The v1-" ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++ @@ -129,11 +113,9 @@ "For more information, see: https://wiki.haskell.org/Cabal/NewBuild\n" -toLegacyCmd :: (Bool -> CommandSpec (globals -> IO action)) -> [CommandSpec (globals -> IO action)] -toLegacyCmd mkSpec = [toDeprecated (mkSpec True), toLegacy (mkSpec False)] +toLegacyCmd :: CommandSpec (globals -> IO action) -> [CommandSpec (globals -> IO action)] +toLegacyCmd mkSpec = [toLegacy mkSpec] where - legacyMsg = T.unpack . T.replace "v1-" "" . T.pack - toLegacy (CommandSpec origUi@CommandUI{..} action type') = CommandSpec legUi action type' where legUi = origUi @@ -143,17 +125,6 @@ Nothing -> legacyNote commandName } - toDeprecated (CommandSpec origUi@CommandUI{..} action type') = CommandSpec depUi action type' - where - depUi = origUi - { commandName = legacyMsg commandName - , commandUsage = legacyMsg . commandUsage - , commandDescription = (legacyMsg .) <$> commandDescription - , commandNotes = Just $ \pname -> case commandNotes of - Just notes -> legacyMsg (notes pname) ++ "\n" ++ deprecationNote commandName - Nothing -> deprecationNote commandName - } - legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] legacyCmd ui action = toLegacyCmd (regularCmd ui action) @@ -161,13 +132,22 @@ legacyWrapperCmd ui verbosity' distPref = toLegacyCmd (wrapperCmd ui verbosity' distPref) newCmd :: CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] -newCmd origUi@CommandUI{..} action = [cmd v2Ui, cmd origUi] +newCmd origUi@CommandUI{..} action = [cmd defaultUi, cmd newUi, cmd origUi] where cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand - v2Msg = T.unpack . T.replace "new-" "v2-" . T.pack - v2Ui = origUi - { commandName = v2Msg commandName - , commandUsage = v2Msg . commandUsage - , commandDescription = (v2Msg .) <$> commandDescription - , commandNotes = (v2Msg .) <$> commandDescription + + newMsg = T.unpack . T.replace "v2-" "new-" . T.pack + newUi = origUi + { commandName = newMsg commandName + , commandUsage = newMsg . commandUsage + , commandDescription = (newMsg .) <$> commandDescription + , commandNotes = (newMsg .) <$> commandDescription + } + + defaultMsg = T.unpack . T.replace "v2-" "" . T.pack + defaultUi = origUi + { commandName = defaultMsg commandName + , commandUsage = defaultMsg . commandUsage + , commandDescription = (defaultMsg .) <$> commandDescription + , commandNotes = (defaultMsg .) <$> commandDescription } diff --git a/Distribution/Client/CmdRepl.hs b/Distribution/Client/CmdRepl.hs --- a/Distribution/Client/CmdRepl.hs +++ b/Distribution/Client/CmdRepl.hs @@ -45,16 +45,20 @@ import Distribution.Client.Types ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage ) import Distribution.Simple.Setup - ( HaddockFlags, fromFlagOrDefault, replOptions + ( HaddockFlags, TestFlags, fromFlagOrDefault, replOptions , Flag(..), toFlag, trueArg, falseArg ) import Distribution.Simple.Command ( CommandUI(..), liftOption, usageAlternatives, option , ShowOrParseArgs, OptionField, reqArg ) +import Distribution.Compiler + ( CompilerFlavor(GHC) ) +import Distribution.Simple.Compiler + ( compilerCompatVersion ) import Distribution.Package ( Package(..), packageName, UnitId, installedUnitId ) import Distribution.PackageDescription.PrettyPrint -import Distribution.Parsec.Class - ( Parsec(..) ) +import Distribution.Parsec + ( Parsec(..), parsecCommaList ) import Distribution.Pretty ( prettyShow ) import Distribution.ReadE @@ -72,17 +76,19 @@ ( Dependency(..) ) import Distribution.Types.GenericPackageDescription ( emptyGenericPackageDescription ) +import Distribution.Types.LibraryName + ( LibraryName(..) ) import Distribution.Types.PackageDescription ( PackageDescription(..), emptyPackageDescription ) +import Distribution.Types.PackageName.Magic + ( fakePackageId ) import Distribution.Types.Library ( Library(..), emptyLibrary ) -import Distribution.Types.PackageId - ( PackageIdentifier(..) ) import Distribution.Types.Version - ( mkVersion, version0 ) + ( mkVersion ) import Distribution.Types.VersionRange ( anyVersion ) -import Distribution.Text +import Distribution.Deprecated.Text ( display ) import Distribution.Verbosity ( Verbosity, normal, lessVerbose ) @@ -96,7 +102,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set import System.Directory - ( getTemporaryDirectory, removeDirectoryRecursive ) + ( getCurrentDirectory, getTemporaryDirectory, removeDirectoryRecursive ) import System.FilePath ( () ) @@ -133,19 +139,18 @@ where dependencyReadE :: ReadE [Dependency] dependencyReadE = - fmap pure $ - parsecToReadE - ("couldn't parse dependency: " ++) - parsec + parsecToReadE + ("couldn't parse dependency: " ++) + (parsecCommaList parsec) -replCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, ReplFlags, EnvFlags) +replCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, ReplFlags, EnvFlags) replCommand = Client.installCommand { - commandName = "new-repl", + commandName = "v2-repl", commandSynopsis = "Open an interactive session for the given component.", - commandUsage = usageAlternatives "new-repl" [ "[TARGET] [FLAGS]" ], + commandUsage = usageAlternatives "v2-repl" [ "[TARGET] [FLAGS]" ], commandDescription = Just $ \_ -> wrapText $ "Open an interactive session for a component within the project. The " - ++ "available targets are the same as for the 'new-build' command: " + ++ "available targets are the same as for the 'v2-build' command: " ++ "individual components within packages in the project, including " ++ "libraries, executables, test-suites or benchmarks. Packages can " ++ "also be specified in which case the library component in the " @@ -158,45 +163,45 @@ ++ "'cabal.project.local' and other files.", commandNotes = Just $ \pname -> "Examples, open an interactive session:\n" - ++ " " ++ pname ++ " new-repl\n" + ++ " " ++ pname ++ " v2-repl\n" ++ " for the default component in the package in the current directory\n" - ++ " " ++ pname ++ " new-repl pkgname\n" + ++ " " ++ pname ++ " v2-repl pkgname\n" ++ " for the default component in the package named 'pkgname'\n" - ++ " " ++ pname ++ " new-repl ./pkgfoo\n" + ++ " " ++ pname ++ " v2-repl ./pkgfoo\n" ++ " for the default component in the package in the ./pkgfoo directory\n" - ++ " " ++ pname ++ " new-repl cname\n" + ++ " " ++ pname ++ " v2-repl cname\n" ++ " for the component named 'cname'\n" - ++ " " ++ pname ++ " new-repl pkgname:cname\n" + ++ " " ++ pname ++ " v2-repl pkgname:cname\n" ++ " for the component 'cname' in the package 'pkgname'\n\n" - ++ " " ++ pname ++ " new-repl --build-depends lens\n" + ++ " " ++ pname ++ " v2-repl --build-depends lens\n" ++ " add the latest version of the library 'lens' to the default component " ++ "(or no componentif there is no project present)\n" - ++ " " ++ pname ++ " new-repl --build-depends \"lens >= 4.15 && < 4.18\"\n" + ++ " " ++ pname ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n" ++ " add a version (constrained between 4.15 and 4.18) of the library 'lens' " ++ "to the default component (or no component if there is no project present)\n" ++ cmdCommonHelpTextNewBuildBeta, - commandDefaultFlags = (configFlags,configExFlags,installFlags,haddockFlags,[],defaultEnvFlags), + commandDefaultFlags = (configFlags,configExFlags,installFlags,haddockFlags,testFlags,[],defaultEnvFlags), commandOptions = \showOrParseArgs -> map liftOriginal (commandOptions Client.installCommand showOrParseArgs) ++ map liftReplOpts (replOptions showOrParseArgs) ++ map liftEnvOpts (envOptions showOrParseArgs) } where - (configFlags,configExFlags,installFlags,haddockFlags) = commandDefaultFlags Client.installCommand + (configFlags,configExFlags,installFlags,haddockFlags,testFlags) = commandDefaultFlags Client.installCommand liftOriginal = liftOption projectOriginal updateOriginal liftReplOpts = liftOption projectReplOpts updateReplOpts liftEnvOpts = liftOption projectEnvOpts updateEnvOpts - projectOriginal (a,b,c,d,_,_) = (a,b,c,d) - updateOriginal (a,b,c,d) (_,_,_,_,e,f) = (a,b,c,d,e,f) + projectOriginal (a,b,c,d,e,_,_) = (a,b,c,d,e) + updateOriginal (a,b,c,d,e) (_,_,_,_,_,f,g) = (a,b,c,d,e,f,g) - projectReplOpts (_,_,_,_,e,_) = e - updateReplOpts e (a,b,c,d,_,f) = (a,b,c,d,e,f) + projectReplOpts (_,_,_,_,_,f,_) = f + updateReplOpts f (a,b,c,d,e,_,g) = (a,b,c,d,e,f,g) - projectEnvOpts (_,_,_,_,_,f) = f - updateEnvOpts f (a,b,c,d,e,_) = (a,b,c,d,e,f) + projectEnvOpts (_,_,_,_,_,_,g) = g + updateEnvOpts g (a,b,c,d,e,f,_) = (a,b,c,d,e,f,g) -- | The @repl@ command is very much like @build@. It brings the install plan -- up to date, selects that part of the plan needed by the given or implicit @@ -209,16 +214,16 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, ReplFlags, EnvFlags) +replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, ReplFlags, EnvFlags) -> [String] -> GlobalFlags -> IO () -replAction (configFlags, configExFlags, installFlags, haddockFlags, replFlags, envFlags) +replAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags, replFlags, envFlags) targetStrings globalFlags = do let ignoreProject = fromFlagOrDefault False (envIgnoreProject envFlags) with = withProject cliConfig verbosity targetStrings without config = withoutProject (config <> cliConfig) verbosity targetStrings - (baseCtx, targetSelectors, finalizer) <- if ignoreProject + (baseCtx, targetSelectors, finalizer, replType) <- if ignoreProject then do globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag without globalConfig @@ -255,7 +260,7 @@ -- In addition, to avoid a *third* trip through the solver, we are -- replicating the second half of 'runProjectPreBuildPhase' by hand -- here. - (buildCtx, replFlags') <- withInstallPlan verbosity baseCtx' $ + (buildCtx, replFlags'') <- withInstallPlan verbosity baseCtx' $ \elaboratedPlan elaboratedShared' -> do let ProjectBaseContext{..} = baseCtx' @@ -268,9 +273,6 @@ targets elaboratedPlan includeTransitive = fromFlagOrDefault True (envIncludeTransitive envFlags) - replFlags' = case originalComponent of - Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci - Nothing -> [] pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared' elaboratedPlan' @@ -287,11 +289,27 @@ , pkgsBuildStatus , targetsMap = targets } - return (buildCtx, replFlags') + + ElaboratedSharedConfig { pkgConfigCompiler = compiler } = elaboratedShared' + + -- First version of GHC where GHCi supported the flag we need. + -- https://downloads.haskell.org/~ghc/7.6.1/docs/html/users_guide/release-7-6-1.html + minGhciScriptVersion = mkVersion [7, 6] + replFlags' = case originalComponent of + Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci + Nothing -> [] + replFlags'' = case replType of + GlobalRepl scriptPath + | Just version <- compilerCompatVersion GHC compiler + , version >= minGhciScriptVersion -> ("-ghci-script" ++ scriptPath) : replFlags' + _ -> replFlags' + + return (buildCtx, replFlags'') + let buildCtx' = buildCtx { elaboratedShared = (elaboratedShared buildCtx) - { pkgConfigReplOptions = replFlags ++ replFlags' } + { pkgConfigReplOptions = replFlags ++ replFlags'' } } printPlan verbosity baseCtx' buildCtx' @@ -302,7 +320,9 @@ verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) validatedTargets elaboratedPlan targetSelectors = do @@ -332,16 +352,26 @@ } deriving (Show) -withProject :: ProjectConfig -> Verbosity -> [String] -> IO (ProjectBaseContext, [TargetSelector], IO ()) +-- | Tracks what type of GHCi instance we're creating. +data ReplType = ProjectRepl + | GlobalRepl FilePath -- ^ The 'FilePath' argument is path to a GHCi + -- script responsible for changing to the + -- correct directory. Only works on GHC geq + -- 7.6, though. 🙁 + deriving (Show, Eq) + +withProject :: ProjectConfig -> Verbosity -> [String] + -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType) withProject cliConfig verbosity targetStrings = do - baseCtx <- establishProjectBaseContext verbosity cliConfig + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand targetSelectors <- either (reportTargetSelectorProblems verbosity) return =<< readTargetSelectors (localPackages baseCtx) (Just LibKind) targetStrings - return (baseCtx, targetSelectors, return ()) + return (baseCtx, targetSelectors, return (), ProjectRepl) -withoutProject :: ProjectConfig -> Verbosity -> [String] -> IO (ProjectBaseContext, [TargetSelector], IO ()) +withoutProject :: ProjectConfig -> Verbosity -> [String] + -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType) withoutProject config verbosity extraArgs = do unless (null extraArgs) $ die' verbosity $ "'repl' doesn't take any extra arguments when outside a project: " ++ unwords extraArgs @@ -370,23 +400,28 @@ { targetBuildDepends = [baseDep] , defaultLanguage = Just Haskell2010 } - baseDep = Dependency "base" anyVersion - pkgId = PackageIdentifier "fake-package" version0 + baseDep = Dependency "base" anyVersion (Set.singleton LMainLibName) + pkgId = fakePackageId writeGenericPackageDescription (tempDir "fake-package.cabal") genericPackageDescription + let ghciScriptPath = tempDir "setcwd.ghci" + cwd <- getCurrentDirectory + writeFile ghciScriptPath (":cd " ++ cwd) + baseCtx <- establishDummyProjectBaseContext verbosity config tempDir [SpecificSourcePackage sourcePackage] + OtherCommand let targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing] finalizer = handleDoesNotExist () (removeDirectoryRecursive tempDir) - return (baseCtx, targetSelectors, finalizer) + return (baseCtx, targetSelectors, finalizer, GlobalRepl ghciScriptPath) addDepsToProjectTarget :: [Dependency] -> PackageId diff --git a/Distribution/Client/CmdRun.hs b/Distribution/Client/CmdRun.hs --- a/Distribution/Client/CmdRun.hs +++ b/Distribution/Client/CmdRun.hs @@ -9,7 +9,7 @@ -- * The @run@ CLI and action runCommand, runAction, - handleShebang, + handleShebang, validScript, -- * Internals exposed for testing TargetProblem(..), @@ -29,17 +29,17 @@ ( defaultGlobalFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags, fromFlagOrDefault ) + ( HaddockFlags, TestFlags, fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Types.ComponentName ( showComponentName ) -import Distribution.Text +import Distribution.Deprecated.Text ( display ) import Distribution.Verbosity ( Verbosity, normal ) import Distribution.Simple.Utils - ( wrapText, die', ordNub, info + ( wrapText, warn, die', ordNub, info , createTempDirectory, handleDoesNotExist ) import Distribution.Client.CmdInstall ( establishDummyProjectBaseContext ) @@ -73,12 +73,10 @@ ( executableFieldGrammar ) import Distribution.PackageDescription.PrettyPrint ( writeGenericPackageDescription ) -import Distribution.Parsec.Common +import Distribution.Parsec ( Position(..) ) -import Distribution.Parsec.ParseResult - ( ParseResult, parseString, parseFatalFailure ) -import Distribution.Parsec.Parser - ( readFields ) +import Distribution.Fields + ( ParseResult, parseString, parseFatalFailure, readFields ) import qualified Distribution.SPDX.License as SPDX import Distribution.Solver.Types.SourcePackage as SP ( SourcePackage(..) ) @@ -92,10 +90,10 @@ ( GenericPackageDescription(..), emptyGenericPackageDescription ) import Distribution.Types.PackageDescription ( PackageDescription(..), emptyPackageDescription ) -import Distribution.Types.PackageId - ( PackageIdentifier(..) ) import Distribution.Types.Version - ( mkVersion, version0 ) + ( mkVersion ) +import Distribution.Types.PackageName.Magic + ( fakePackageId ) import Language.Haskell.Extension ( Language(..) ) @@ -106,13 +104,14 @@ import System.Directory ( getTemporaryDirectory, removeDirectoryRecursive, doesFileExist ) import System.FilePath - ( () ) + ( (), isValid, isPathSeparator, takeExtension ) -runCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + +runCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) runCommand = Client.installCommand { - commandName = "new-run", + commandName = "v2-run", commandSynopsis = "Run an executable.", - commandUsage = usageAlternatives "new-run" + commandUsage = usageAlternatives "v2-run" [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ], commandDescription = Just $ \pname -> wrapText $ "Runs the specified executable-like component (an executable, a test, " @@ -134,18 +133,18 @@ ++ "'cabal.project.local' and other files.", commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " new-run\n" + ++ " " ++ pname ++ " v2-run\n" ++ " Run the executable-like in the package in the current directory\n" - ++ " " ++ pname ++ " new-run foo-tool\n" + ++ " " ++ pname ++ " v2-run foo-tool\n" ++ " Run the named executable-like (in any package in the project)\n" - ++ " " ++ pname ++ " new-run pkgfoo:foo-tool\n" + ++ " " ++ pname ++ " v2-run pkgfoo:foo-tool\n" ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n" - ++ " " ++ pname ++ " new-run foo -O2 -- dothing --fooflag\n" + ++ " " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n" ++ " Build with '-O2' and run the program, passing it extra arguments.\n\n" ++ cmdCommonHelpTextNewBuildBeta } - + -- | The @run@ command runs a specified executable-like component, building it -- first if necessary. The component can be either an executable, a test, -- or a benchmark. This is particularly useful for passing arguments to @@ -154,28 +153,30 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -runAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +runAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) -> [String] -> GlobalFlags -> IO () -runAction (configFlags, configExFlags, installFlags, haddockFlags) +runAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) targetStrings globalFlags = do globalTmp <- getTemporaryDirectory tempDir <- createTempDirectory globalTmp "cabal-repl." - + let - with = - establishProjectBaseContext verbosity cliConfig - without config = - establishDummyProjectBaseContext verbosity (config <> cliConfig) tempDir [] + with = + establishProjectBaseContext verbosity cliConfig OtherCommand + without config = + establishDummyProjectBaseContext verbosity (config <> cliConfig) tempDir [] OtherCommand baseCtx <- withProjectOrGlobalConfig verbosity globalConfigFlag with without let scriptOrError script err = do exists <- doesFileExist script + let pol | takeExtension script == ".lhs" = LiterateHaskell + | otherwise = PlainHaskell if exists - then BS.readFile script >>= handleScriptCase verbosity baseCtx tempDir + then BS.readFile script >>= handleScriptCase verbosity pol baseCtx tempDir else reportTargetSelectorProblems verbosity err - + (baseCtx', targetSelectors) <- readTargetSelectors (localPackages baseCtx) (Just ExeKind) (take 1 targetStrings) >>= \case @@ -187,7 +188,7 @@ | TargetString1 script <- t -> scriptOrError script err Left err -> reportTargetSelectorProblems verbosity err Right sels -> return (baseCtx, sels) - + buildCtx <- runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do @@ -290,19 +291,43 @@ (distDirLayout baseCtx) elaboratedPlan } - + handleDoesNotExist () (removeDirectoryRecursive tempDir) where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) -handleShebang :: String -> IO () -handleShebang script = - runAction (commandDefaultFlags runCommand) [script] defaultGlobalFlags +-- | Used by the main CLI parser as heuristic to decide whether @cabal@ was +-- invoked as a script interpreter, i.e. via +-- +-- > #! /usr/bin/env cabal +-- +-- or +-- +-- > #! /usr/bin/cabal +-- +-- As the first argument passed to `cabal` will be a filepath to the +-- script to be interpreted. +-- +-- See also 'handleShebang' +validScript :: String -> IO Bool +validScript script + | isValid script && any isPathSeparator script = doesFileExist script + | otherwise = return False +-- | Handle @cabal@ invoked as script interpreter, see also 'validScript' +-- +-- First argument is the 'FilePath' to the script to be executed; second +-- argument is a list of arguments to be passed to the script. +handleShebang :: FilePath -> [String] -> IO () +handleShebang script args = + runAction (commandDefaultFlags runCommand) (script:args) defaultGlobalFlags + parseScriptBlock :: BS.ByteString -> ParseResult Executable parseScriptBlock str = case readFields str of @@ -316,48 +341,84 @@ readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block" -readScriptBlockFromScript :: Verbosity -> BS.ByteString -> IO (Executable, BS.ByteString) -readScriptBlockFromScript verbosity str = +readScriptBlockFromScript :: Verbosity -> PlainOrLiterate -> BS.ByteString -> IO (Executable, BS.ByteString) +readScriptBlockFromScript verbosity pol str = do + str' <- case extractScriptBlock pol str of + Left e -> die' verbosity $ "Failed extracting script block: " ++ e + Right x -> return x + when (BS.all isSpace str') $ warn verbosity "Empty script block" (\x -> (x, noShebang)) <$> readScriptBlock verbosity str' where - start = "{- cabal:" - end = "-}" + noShebang = BS.unlines . filter (not . BS.isPrefixOf "#!") . BS.lines $ str - str' = BS.unlines - . takeWhile (/= end) - . drop 1 . dropWhile (/= start) - $ lines' - - noShebang = BS.unlines - . filter ((/= "#!") . BS.take 2) - $ lines' +-- | Extract the first encountered script metadata block started end +-- terminated by the tokens +-- +-- * @{- cabal:@ +-- +-- * @-}@ +-- +-- appearing alone on lines (while tolerating trailing whitespace). +-- These tokens are not part of the 'Right' result. +-- +-- In case of missing or unterminated blocks a 'Left'-error is +-- returned. +extractScriptBlock :: PlainOrLiterate -> BS.ByteString -> Either String BS.ByteString +extractScriptBlock _pol str = goPre (BS.lines str) + where + isStartMarker = (== startMarker) . stripTrailSpace + isEndMarker = (== endMarker) . stripTrailSpace - lines' = BS.lines str + stripTrailSpace = fst . BS.spanEnd isSpace -handleScriptCase :: Verbosity - -> ProjectBaseContext - -> FilePath - -> BS.ByteString - -> IO (ProjectBaseContext, [TargetSelector]) -handleScriptCase verbosity baseCtx tempDir scriptContents = do - (executable, contents') <- readScriptBlockFromScript verbosity scriptContents - + -- before start marker + goPre ls = case dropWhile (not . isStartMarker) ls of + [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found" + (_:ls') -> goBody [] ls' + + goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found" + goBody acc (l:ls) + | isEndMarker l = Right $! BS.unlines $ reverse acc + | otherwise = goBody (l:acc) ls + + startMarker, endMarker :: BS.ByteString + startMarker = fromString "{- cabal:" + endMarker = fromString "-}" + +data PlainOrLiterate + = PlainHaskell + | LiterateHaskell + +handleScriptCase + :: Verbosity + -> PlainOrLiterate + -> ProjectBaseContext + -> FilePath + -> BS.ByteString + -> IO (ProjectBaseContext, [TargetSelector]) +handleScriptCase verbosity pol baseCtx tempDir scriptContents = do + (executable, contents') <- readScriptBlockFromScript verbosity pol scriptContents + -- We need to create a dummy package that lives in our dummy project. let + mainName = case pol of + PlainHaskell -> "Main.hs" + LiterateHaskell -> "Main.lhs" + sourcePackage = SourcePackage - { packageInfoId = pkgId - , SP.packageDescription = genericPackageDescription - , packageSource = LocalUnpackedPackage tempDir - , packageDescrOverride = Nothing + { packageInfoId = pkgId + , SP.packageDescription = genericPackageDescription + , packageSource = LocalUnpackedPackage tempDir + , packageDescrOverride = Nothing } - genericPackageDescription = emptyGenericPackageDescription + genericPackageDescription = emptyGenericPackageDescription { GPD.packageDescription = packageDescription - , condExecutables = [("script", CondNode executable' targetBuildDepends [])] + , condExecutables = [("script", CondNode executable' targetBuildDepends [])] } executable' = executable - { modulePath = "Main.hs" - , buildInfo = binfo - { defaultLanguage = + { modulePath = mainName + , buildInfo = binfo + { defaultLanguage = case defaultLanguage of just@(Just _) -> just Nothing -> Just Haskell2010 @@ -369,13 +430,13 @@ , specVersionRaw = Left (mkVersion [2, 2]) , licenseRaw = Left SPDX.NONE } - pkgId = PackageIdentifier "fake-package" version0 + pkgId = fakePackageId writeGenericPackageDescription (tempDir "fake-package.cabal") genericPackageDescription - BS.writeFile (tempDir "Main.hs") contents' + BS.writeFile (tempDir mainName) contents' let - baseCtx' = baseCtx + baseCtx' = baseCtx { localPackages = localPackages baseCtx ++ [SpecificSourcePackage sourcePackage] } targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing] diff --git a/Distribution/Client/CmdSdist.hs b/Distribution/Client/CmdSdist.hs --- a/Distribution/Client/CmdSdist.hs +++ b/Distribution/Client/CmdSdist.hs @@ -1,25 +1,25 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -module Distribution.Client.CmdSdist +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +module Distribution.Client.CmdSdist ( sdistCommand, sdistAction, packageToSdist , SdistFlags(..), defaultSdistFlags - , OutputFormat(..), ArchiveFormat(..) ) where + , OutputFormat(..)) where import Distribution.Client.CmdErrorMessages ( Plural(..), renderComponentKind ) import Distribution.Client.ProjectOrchestration - ( ProjectBaseContext(..), establishProjectBaseContext ) + ( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext ) import Distribution.Client.TargetSelector ( TargetSelector(..), ComponentKind , readTargetSelectors, reportTargetSelectorProblems ) import Distribution.Client.RebuildMonad ( runRebuild ) import Distribution.Client.Setup - ( ArchiveFormat(..), GlobalFlags(..) ) + ( GlobalFlags(..) ) import Distribution.Solver.Types.SourcePackage ( SourcePackage(..) ) import Distribution.Client.Types @@ -41,7 +41,7 @@ import Distribution.ReadE ( succeedReadE ) import Distribution.Simple.Command - ( CommandUI(..), option, choiceOpt, reqArg ) + ( CommandUI(..), option, reqArg ) import Distribution.Simple.PreProcess ( knownSuffixHandlers ) import Distribution.Simple.Setup @@ -51,7 +51,7 @@ import Distribution.Simple.SrcDist ( listPackageSources ) import Distribution.Simple.Utils - ( die', notice, withOutputMarker ) + ( die', notice, withOutputMarker, wrapText ) import Distribution.Types.ComponentName ( ComponentName, showComponentName ) import Distribution.Types.PackageName @@ -61,26 +61,23 @@ import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar -import qualified Codec.Archive.Zip as Zip import qualified Codec.Compression.GZip as GZip import Control.Exception ( throwIO ) import Control.Monad - ( when, forM, forM_ ) + ( when, forM_ ) import Control.Monad.Trans ( liftIO ) import Control.Monad.State.Lazy ( StateT, modify, gets, evalStateT ) import Control.Monad.Writer.Lazy ( WriterT, tell, execWriterT ) -import Data.Bits - ( shiftL ) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Either ( partitionEithers ) import Data.List - ( find, sortOn, nub, intercalate ) + ( find, sortOn, nub ) import qualified Data.Set as Set import System.Directory ( getCurrentDirectory, setCurrentDirectory @@ -90,11 +87,11 @@ sdistCommand :: CommandUI SdistFlags sdistCommand = CommandUI - { commandName = "new-sdist" + { commandName = "v2-sdist" , commandSynopsis = "Generate a source distribution file (.tar.gz)." , commandUsage = \pname -> - "Usage: " ++ pname ++ " new-sdist [FLAGS] [PACKAGES]\n" - , commandDescription = Just $ \_ -> + "Usage: " ++ pname ++ " v2-sdist [FLAGS] [PACKAGES]\n" + , commandDescription = Just $ \_ -> wrapText "Generates tarballs of project packages suitable for upload to Hackage." , commandNotes = Nothing , commandDefaultFlags = defaultSdistFlags @@ -116,16 +113,6 @@ "Separate the source files with NUL bytes rather than newlines." sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v }) trueArg - , option [] ["archive-format"] - "Choose what type of archive to create. No effect if given with '--list-only'" - sdistArchiveFormat (\v flags -> flags { sdistArchiveFormat = v }) - (choiceOpt - [ (Flag TargzFormat, ([], ["targz"]), - "Produce a '.tar.gz' format archive (default and required for uploading to hackage)") - , (Flag ZipFormat, ([], ["zip"]), - "Produce a '.zip' format archive") - ] - ) , option ['o'] ["output-dir", "outputdir"] "Choose the output directory of this command. '-' sends all output to stdout" sdistOutputPath (\o flags -> flags { sdistOutputPath = o }) @@ -139,7 +126,6 @@ , sdistProjectFile :: Flag FilePath , sdistListSources :: Flag Bool , sdistNulSeparated :: Flag Bool - , sdistArchiveFormat :: Flag ArchiveFormat , sdistOutputPath :: Flag FilePath } @@ -150,7 +136,6 @@ , sdistProjectFile = mempty , sdistListSources = toFlag False , sdistNulSeparated = toFlag False - , sdistArchiveFormat = toFlag TargzFormat , sdistOutputPath = mempty } @@ -164,49 +149,47 @@ globalConfig = globalConfigFile globalFlags listSources = fromFlagOrDefault False sdistListSources nulSeparated = fromFlagOrDefault False sdistNulSeparated - archiveFormat = fromFlagOrDefault TargzFormat sdistArchiveFormat mOutputPath = flagToMaybe sdistOutputPath - + projectRoot <- either throwIO return =<< findProjectRoot Nothing mProjectFile let distLayout = defaultDistDirLayout projectRoot mDistDirectory dir <- getCurrentDirectory projectConfig <- runRebuild dir $ readProjectConfig verbosity globalConfig distLayout - baseCtx <- establishProjectBaseContext verbosity projectConfig + baseCtx <- establishProjectBaseContext verbosity projectConfig OtherCommand let localPkgs = localPackages baseCtx targetSelectors <- either (reportTargetSelectorProblems verbosity) return =<< readTargetSelectors localPkgs Nothing targetStrings - + mOutputPath' <- case mOutputPath of Just "-" -> return (Just "-") Just path -> Just <$> makeAbsolute path Nothing -> return Nothing - - let + + let format = if | listSources, nulSeparated -> SourceList '\0' | listSources -> SourceList '\n' - | otherwise -> Archive archiveFormat + | otherwise -> TarGzArchive ext = case format of - SourceList _ -> "list" - Archive TargzFormat -> "tar.gz" - Archive ZipFormat -> "zip" - + SourceList _ -> "list" + TarGzArchive -> "tar.gz" + outputPath pkg = case mOutputPath' of Just path | path == "-" -> "-" | otherwise -> path prettyShow (packageId pkg) <.> ext Nothing | listSources -> "-" - | otherwise -> distSdistFile distLayout (packageId pkg) archiveFormat + | otherwise -> distSdistFile distLayout (packageId pkg) createDirectoryIfMissing True (distSdistDirectory distLayout) - + case reifyTargetSelectors localPkgs targetSelectors of Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs - Right pkgs - | length pkgs > 1, not listSources, Just "-" <- mOutputPath' -> + Right pkgs + | length pkgs > 1, not listSources, Just "-" <- mOutputPath' -> die' verbosity "Can't write multiple tarballs to standard output!" | otherwise -> mapM_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distLayout) format (outputPath pkg) pkg) pkgs @@ -215,7 +198,7 @@ deriving (Show, Eq) data OutputFormat = SourceList Char - | Archive ArchiveFormat + | TarGzArchive deriving (Show, Eq) packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO () @@ -230,17 +213,22 @@ RemoteTarballPackage {} -> death RepoTarballPackage {} -> death - let write = if outputFile == "-" - then putStr . withOutputMarker verbosity . BSL.unpack - else BSL.writeFile outputFile + let -- Write String to stdout or file, using the default TextEncoding. + write + | outputFile == "-" = putStr . withOutputMarker verbosity + | otherwise = writeFile outputFile + -- Write raw ByteString to stdout or file as it is, without encoding. + writeLBS + | outputFile == "-" = BSL.putStr + | otherwise = BSL.writeFile outputFile case dir0 of Left tgz -> do case format of - Archive TargzFormat -> do - write =<< BSL.readFile tgz + TarGzArchive -> do + writeLBS =<< BSL.readFile tgz when (outputFile /= "-") $ - notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" + notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" _ -> die' verbosity ("cannot convert tarball package to " ++ show format) Right dir -> do @@ -256,10 +244,10 @@ case format of SourceList nulSep -> do let prefix = makeRelative projectRootDir dir - write (BSL.pack . (++ [nulSep]) . intercalate [nulSep] . fmap ((prefix ) . snd) $ files) + write $ concat [prefix i ++ [nulSep] | (_, i) <- files] when (outputFile /= "-") $ notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n" - Archive TargzFormat -> do + TarGzArchive -> do let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) () entriesM = do let prefix = prettyShow (packageId pkg) @@ -298,29 +286,16 @@ -- after the epoch is during 2001-09-09, so that does -- nicely. See #5596. setModTime entry = entry { Tar.entryTime = 1000000000 } - write . normalize . GZip.compress . Tar.write $ fmap setModTime entries + writeLBS . normalize . GZip.compress . Tar.write $ fmap setModTime entries when (outputFile /= "-") $ notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" - Archive ZipFormat -> do - let prefix = prettyShow (packageId pkg) - entries <- forM files $ \(perm, file) -> do - let perm' = case perm of - -- -rwxr-xr-x - Exec -> 0o010755 `shiftL` 16 - -- -rw-r--r-- - NoExec -> 0o010644 `shiftL` 16 - contents <- BSL.readFile file - return $ (Zip.toEntry (prefix file) 0 contents) { Zip.eExternalFileAttributes = perm' } - let archive = foldr Zip.addEntryToArchive Zip.emptyArchive entries - write (Zip.fromArchive archive) - when (outputFile /= "-") $ - notice verbosity $ "Wrote zip sdist to " ++ outputFile ++ "\n" + setCurrentDirectory oldPwd -- reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage] -reifyTargetSelectors pkgs sels = +reifyTargetSelectors pkgs sels = case partitionEithers (foldMap go sels) of ([], sels') -> Right sels' (errs, _) -> Left errs @@ -332,7 +307,7 @@ getPkg pid = case find ((== pid) . packageId) pkgs' of Just pkg -> Right pkg Nothing -> error "The impossible happened: we have a reference to a local package that isn't in localPackages." - + go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage] go (TargetPackage _ pids Nothing) = fmap getPkg pids go (TargetAllPackages Nothing) = Right <$> pkgs' @@ -359,4 +334,3 @@ renderTargetProblem (NonlocalPackageNotAllowed pname) = "The package " ++ unPackageName pname ++ " cannot be packaged for distribution, because it is not " ++ "local to this project." - diff --git a/Distribution/Client/CmdTest.hs b/Distribution/Client/CmdTest.hs --- a/Distribution/Client/CmdTest.hs +++ b/Distribution/Client/CmdTest.hs @@ -17,28 +17,31 @@ import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags, fromFlagOrDefault ) + ( HaddockFlags, TestFlags(..), fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) -import Distribution.Text +import Distribution.Simple.Flag + ( Flag(..) ) +import Distribution.Deprecated.Text ( display ) import Distribution.Verbosity ( Verbosity, normal ) import Distribution.Simple.Utils - ( wrapText, die' ) + ( notice, wrapText, die' ) import Control.Monad (when) +import qualified System.Exit (exitSuccess) -testCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -testCommand = Client.installCommand { - commandName = "new-test", - commandSynopsis = "Run test-suites", - commandUsage = usageAlternatives "new-test" [ "[TARGETS] [FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ +testCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +testCommand = Client.installCommand + { commandName = "v2-test" + , commandSynopsis = "Run test-suites" + , commandUsage = usageAlternatives "v2-test" [ "[TARGETS] [FLAGS]" ] + , commandDescription = Just $ \_ -> wrapText $ "Runs the specified test-suites, first ensuring they are up to " ++ "date.\n\n" @@ -53,22 +56,24 @@ ++ "'cabal.project.local' and other files.\n\n" ++ "To pass command-line arguments to a test suite, see the " - ++ "new-run command.", - commandNotes = Just $ \pname -> + ++ "v2-run command." + , commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " new-test\n" + ++ " " ++ pname ++ " v2-test\n" ++ " Run all the test-suites in the package in the current directory\n" - ++ " " ++ pname ++ " new-test pkgname\n" + ++ " " ++ pname ++ " v2-test pkgname\n" ++ " Run all the test-suites in the package named pkgname\n" - ++ " " ++ pname ++ " new-test cname\n" + ++ " " ++ pname ++ " v2-test cname\n" ++ " Run the test-suite named cname\n" - ++ " " ++ pname ++ " new-test cname --enable-coverage\n" + ++ " " ++ pname ++ " v2-test cname --enable-coverage\n" ++ " Run the test-suite built with code coverage (including local libs used)\n\n" ++ cmdCommonHelpTextNewBuildBeta - } + } + + -- | The @test@ command is very much like @build@. It brings the install plan -- up to date, selects that part of the plan needed by the given or implicit -- test target(s) and then executes the plan. @@ -79,12 +84,12 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -testAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +testAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) -> [String] -> GlobalFlags -> IO () -testAction (configFlags, configExFlags, installFlags, haddockFlags) +testAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) targetStrings globalFlags = do - baseCtx <- establishProjectBaseContext verbosity cliConfig + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand targetSelectors <- either (reportTargetSelectorProblems verbosity) return =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings @@ -100,7 +105,7 @@ -- Interpret the targets on the command line as test targets -- (as opposed to say build or haddock targets). - targets <- either (reportTargetProblems verbosity) return + targets <- either (reportTargetProblems verbosity failWhenNoTestSuites) return $ resolveTargets selectPackageTargets selectComponentTarget @@ -120,10 +125,13 @@ buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where + failWhenNoTestSuites = testFailWhenNoTestSuites testFlags verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags -- | This defines what a 'TargetSelector' means for the @test@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, @@ -204,10 +212,26 @@ | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget deriving (Eq, Show) -reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a -reportTargetProblems verbosity = - die' verbosity . unlines . map renderTargetProblem +reportTargetProblems :: Verbosity -> Flag Bool -> [TargetProblem] -> IO a +reportTargetProblems verbosity failWhenNoTestSuites problems = + case (failWhenNoTestSuites, problems) of + (Flag True, [TargetProblemNoTests _]) -> + die' verbosity problemsMessage + (_, [TargetProblemNoTests selector]) -> do + notice verbosity (renderAllowedNoTestsProblem selector) + System.Exit.exitSuccess + (_, _) -> die' verbosity problemsMessage + where + problemsMessage = unlines . map renderTargetProblem $ problems +-- | Unless @--test-fail-when-no-test-suites@ flag is passed, we don't +-- @die@ when the target problem is 'TargetProblemNoTests'. +-- Instead, we display a notice saying that no tests have run and +-- indicate how this behaviour was enabled. +renderAllowedNoTestsProblem :: TargetSelector -> String +renderAllowedNoTestsProblem selector = + "No tests to run for " ++ renderTargetSelector selector + renderTargetProblem :: TargetProblem -> String renderTargetProblem (TargetProblemCommon problem) = renderTargetProblemCommon "run" problem @@ -228,6 +252,7 @@ -> "The test command is for running test suites, but the target '" ++ showTargetSelector targetSelector ++ "' refers to " ++ renderTargetSelector targetSelector ++ "." + ++ "\n" ++ show targetSelector _ -> renderTargetProblemNoTargets "test" targetSelector diff --git a/Distribution/Client/CmdUpdate.hs b/Distribution/Client/CmdUpdate.hs --- a/Distribution/Client/CmdUpdate.hs +++ b/Distribution/Client/CmdUpdate.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE CPP, LambdaCase, NamedFieldPuns, RecordWildCards, ViewPatterns, - TupleSections #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: update -- @@ -9,7 +13,7 @@ ) where import Prelude () -import Distribution.Client.Compat.Prelude +import Distribution.Client.Compat.Prelude import Distribution.Client.Compat.Directory ( setModificationTime ) @@ -32,7 +36,7 @@ , UpdateFlags, defaultUpdateFlags , RepoContext(..) ) import Distribution.Simple.Setup - ( HaddockFlags, fromFlagOrDefault ) + ( HaddockFlags, TestFlags, fromFlagOrDefault ) import Distribution.Simple.Utils ( die', notice, wrapText, writeFileAtomic, noticeNoWrap ) import Distribution.Verbosity @@ -41,11 +45,11 @@ import Distribution.Client.IndexUtils ( updateRepoIndexCache, Index(..), writeIndexTimestamp , currentIndexTimestamp, indexBaseName ) -import Distribution.Text +import Distribution.Deprecated.Text ( Text(..), display, simpleParse ) import Data.Maybe (fromJust) -import qualified Distribution.Compat.ReadP as ReadP +import qualified Distribution.Deprecated.ReadP as ReadP import qualified Text.PrettyPrint as Disp import Control.Monad (mapM, mapM_) @@ -60,23 +64,23 @@ import qualified Hackage.Security.Client as Sec updateCommand :: CommandUI ( ConfigFlags, ConfigExFlags - , InstallFlags, HaddockFlags ) + , InstallFlags, HaddockFlags, TestFlags ) updateCommand = Client.installCommand { - commandName = "new-update", + commandName = "v2-update", commandSynopsis = "Updates list of known packages.", - commandUsage = usageAlternatives "new-update" [ "[FLAGS] [REPOS]" ], + commandUsage = usageAlternatives "v2-update" [ "[FLAGS] [REPOS]" ], commandDescription = Just $ \_ -> wrapText $ "For all known remote repositories, download the package list.", commandNotes = Just $ \pname -> "REPO has the format [,] where index-state follows\n" ++ "the same format and syntax that is supported by the --index-state flag.\n\n" ++ "Examples:\n" - ++ " " ++ pname ++ " new-update\n" + ++ " " ++ pname ++ " v2-update\n" ++ " Download the package list for all known remote repositories.\n\n" - ++ " " ++ pname ++ " new-update hackage.haskell.org,@1474732068\n" - ++ " " ++ pname ++ " new-update hackage.haskell.org,2016-09-24T17:47:48Z\n" - ++ " " ++ pname ++ " new-update hackage.haskell.org,HEAD\n" - ++ " " ++ pname ++ " new-update hackage.haskell.org\n" + ++ " " ++ pname ++ " v2-update hackage.haskell.org,@1474732068\n" + ++ " " ++ pname ++ " v2-update hackage.haskell.org,2016-09-24T17:47:48Z\n" + ++ " " ++ pname ++ " v2-update hackage.haskell.org,HEAD\n" + ++ " " ++ pname ++ " v2-update hackage.haskell.org\n" ++ " Download hackage.haskell.org at a specific index state.\n\n" ++ " " ++ pname ++ " new update hackage.haskell.org head.hackage\n" ++ " Download hackage.haskell.org and head.hackage\n" @@ -110,12 +114,12 @@ name <- ReadP.manyTill (ReadP.satisfy (\c -> c /= ',')) ReadP.eof return (UpdateRequest name IndexStateHead) -updateAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +updateAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) -> [String] -> GlobalFlags -> IO () -updateAction (configFlags, configExFlags, installFlags, haddockFlags) +updateAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) extraArgs globalFlags = do projectConfig <- withProjectOrGlobalConfig verbosity globalConfigFlag - (projectConfig <$> establishProjectBaseContext verbosity cliConfig) + (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand) (\globalConfig -> return $ globalConfig <> cliConfig) projectConfigWithSolverRepoContext verbosity @@ -127,7 +131,7 @@ parseArg s = case simpleParse s of Just r -> return r Nothing -> die' verbosity $ - "'new-update' unable to parse repo: \"" ++ s ++ "\"" + "'v2-update' unable to parse repo: \"" ++ s ++ "\"" updateRepoRequests <- mapM parseArg extraArgs unless (null updateRepoRequests) $ do @@ -135,7 +139,7 @@ unknownRepos = [r | (UpdateRequest r _) <- updateRepoRequests , not (r `elem` remoteRepoNames)] unless (null unknownRepos) $ - die' verbosity $ "'new-update' repo(s): \"" + die' verbosity $ "'v2-update' repo(s): \"" ++ intercalate "\", \"" unknownRepos ++ "\" can not be found in known remote repo(s): " ++ intercalate ", " remoteRepoNames @@ -168,7 +172,9 @@ verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, IndexState) @@ -213,5 +219,5 @@ when (current_ts /= nullTimestamp) $ noticeNoWrap verbosity $ "To revert to previous state run:\n" ++ - " cabal new-update '" ++ remoteRepoName (repoRemote repo) + " cabal v2-update '" ++ remoteRepoName (repoRemote repo) ++ "," ++ display current_ts ++ "'\n" diff --git a/Distribution/Client/Compat/Prelude.hs b/Distribution/Client/Compat/Prelude.hs --- a/Distribution/Client/Compat/Prelude.hs +++ b/Distribution/Client/Compat/Prelude.hs @@ -3,7 +3,7 @@ -- | This module does two things: -- --- * Acts as a compatiblity layer, like @base-compat@. +-- * Acts as a compatibility layer, like @base-compat@. -- -- * Provides commonly used imports. -- @@ -13,10 +13,7 @@ module Distribution.Client.Compat.Prelude ( module Distribution.Compat.Prelude.Internal , Prelude.IO - , readMaybe ) where import Prelude (IO) import Distribution.Compat.Prelude.Internal hiding (IO) -import Text.Read - ( readMaybe ) diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs --- a/Distribution/Client/Config.hs +++ b/Distribution/Client/Config.hs @@ -44,35 +44,49 @@ remoteRepoFields ) where +import Language.Haskell.Extension ( Language(Haskell2010) ) + +import Distribution.Deprecated.ViewAsFieldDescr + ( viewAsFieldDescr ) + import Distribution.Client.Types ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) +import qualified Distribution.Client.Init.Types as IT + ( InitFlags(..) ) import Distribution.Client.Setup ( GlobalFlags(..), globalCommand, defaultGlobalFlags , ConfigExFlags(..), configureExOptions, defaultConfigExFlags + , initOptions , InstallFlags(..), installOptions, defaultInstallFlags , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand , showRepo, parseRepo, readRepo ) +import Distribution.Client.CmdInstall.ClientInstallFlags + ( ClientInstallFlags(..), defaultClientInstallFlags + , clientInstallOptions ) import Distribution.Utils.NubList ( NubList, fromNubList, toNubList, overNubList ) +import Distribution.License + ( License(BSD3) ) import Distribution.Simple.Compiler ( DebugInfoLevel(..), OptimisationLevel(..) ) import Distribution.Simple.Setup ( ConfigFlags(..), configureOptions, defaultConfigFlags , HaddockFlags(..), haddockOptions, defaultHaddockFlags + , TestFlags(..), defaultTestFlags , installDirsOptions, optionDistPref , programDbPaths', programDbOptions , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.InstallDirs ( InstallDirs(..), defaultInstallDirs , PathTemplate, toPathTemplate ) -import Distribution.ParseUtils - ( FieldDescr(..), liftField +import Distribution.Deprecated.ParseUtils + ( FieldDescr(..), liftField, runP , ParseResult(..), PError(..), PWarning(..) , locatedErrorMsg, showPWarning , readFields, warning, lineNo @@ -82,13 +96,12 @@ ( parseFields, ppFields, ppSection ) import Distribution.Client.HttpUtils ( isOldHackageURI ) -import qualified Distribution.ParseUtils as ParseUtils +import qualified Distribution.Deprecated.ParseUtils as ParseUtils ( Field(..) ) -import qualified Distribution.Text as Text +import qualified Distribution.Deprecated.Text as Text ( Text(..), display ) import Distribution.Simple.Command - ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) - , viewAsFieldDescr ) + ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) ) import Distribution.Simple.Program ( defaultProgramDb ) import Distribution.Simple.Utils @@ -97,6 +110,8 @@ ( CompilerFlavor(..), defaultCompilerFlavor ) import Distribution.Verbosity ( Verbosity, normal ) +import Distribution.Version + ( mkVersion ) import Distribution.Solver.Types.ConstraintSource @@ -106,7 +121,7 @@ ( fromMaybe ) import Control.Monad ( when, unless, foldM, liftM ) -import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Deprecated.ReadP as Parse ( (<++), option ) import Distribution.Compat.Semigroup import qualified Text.PrettyPrint as Disp @@ -144,14 +159,17 @@ data SavedConfig = SavedConfig { savedGlobalFlags :: GlobalFlags, + savedInitFlags :: IT.InitFlags, savedInstallFlags :: InstallFlags, + savedClientInstallFlags :: ClientInstallFlags, savedConfigureFlags :: ConfigFlags, savedConfigureExFlags :: ConfigExFlags, savedUserInstallDirs :: InstallDirs (Flag PathTemplate), savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate), savedUploadFlags :: UploadFlags, savedReportFlags :: ReportFlags, - savedHaddockFlags :: HaddockFlags + savedHaddockFlags :: HaddockFlags, + savedTestFlags :: TestFlags } deriving Generic instance Monoid SavedConfig where @@ -161,14 +179,17 @@ instance Semigroup SavedConfig where a <> b = SavedConfig { savedGlobalFlags = combinedSavedGlobalFlags, + savedInitFlags = combinedSavedInitFlags, savedInstallFlags = combinedSavedInstallFlags, + savedClientInstallFlags = combinedSavedClientInstallFlags, savedConfigureFlags = combinedSavedConfigureFlags, savedConfigureExFlags = combinedSavedConfigureExFlags, savedUserInstallDirs = combinedSavedUserInstallDirs, savedGlobalInstallDirs = combinedSavedGlobalInstallDirs, savedUploadFlags = combinedSavedUploadFlags, savedReportFlags = combinedSavedReportFlags, - savedHaddockFlags = combinedSavedHaddockFlags + savedHaddockFlags = combinedSavedHaddockFlags, + savedTestFlags = combinedSavedTestFlags } where -- This is ugly, but necessary. If we're mappending two config files, we @@ -241,6 +262,42 @@ combine = combine' savedGlobalFlags lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags + combinedSavedInitFlags = IT.InitFlags { + IT.applicationDirs = combineMonoid savedInitFlags IT.applicationDirs, + IT.author = combine IT.author, + IT.buildTools = combineMonoid savedInitFlags IT.buildTools, + IT.cabalVersion = combine IT.cabalVersion, + IT.category = combine IT.category, + IT.dependencies = combineMonoid savedInitFlags IT.dependencies, + IT.email = combine IT.email, + IT.exposedModules = combineMonoid savedInitFlags IT.exposedModules, + IT.extraSrc = combineMonoid savedInitFlags IT.extraSrc, + IT.homepage = combine IT.homepage, + IT.initHcPath = combine IT.initHcPath, + IT.initVerbosity = combine IT.initVerbosity, + IT.initializeTestSuite = combine IT.initializeTestSuite, + IT.interactive = combine IT.interactive, + IT.language = combine IT.language, + IT.license = combine IT.license, + IT.mainIs = combine IT.mainIs, + IT.minimal = combine IT.minimal, + IT.noComments = combine IT.noComments, + IT.otherExts = combineMonoid savedInitFlags IT.otherExts, + IT.otherModules = combineMonoid savedInitFlags IT.otherModules, + IT.overwrite = combine IT.overwrite, + IT.packageDir = combine IT.packageDir, + IT.packageName = combine IT.packageName, + IT.packageType = combine IT.packageType, + IT.quiet = combine IT.quiet, + IT.simpleProject = combine IT.simpleProject, + IT.sourceDirs = combineMonoid savedInitFlags IT.sourceDirs, + IT.synopsis = combine IT.synopsis, + IT.testDirs = combineMonoid savedInitFlags IT.testDirs, + IT.version = combine IT.version + } + where + combine = combine' savedInitFlags + combinedSavedInstallFlags = InstallFlags { installDocumentation = combine installDocumentation, installHaddockIndex = combine installHaddockIndex, @@ -249,10 +306,12 @@ installMaxBackjumps = combine installMaxBackjumps, installReorderGoals = combine installReorderGoals, installCountConflicts = combine installCountConflicts, + installMinimizeConflictSet = combine installMinimizeConflictSet, installIndependentGoals = combine installIndependentGoals, installShadowPkgs = combine installShadowPkgs, installStrongFlags = combine installStrongFlags, installAllowBootLibInstalls = combine installAllowBootLibInstalls, + installOnlyConstrained = combine installOnlyConstrained, installReinstall = combine installReinstall, installAvoidReinstalls = combine installAvoidReinstalls, installOverrideReinstall = combine installOverrideReinstall, @@ -278,6 +337,16 @@ combine = combine' savedInstallFlags lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags + combinedSavedClientInstallFlags = ClientInstallFlags { + cinstInstallLibs = combine cinstInstallLibs, + cinstEnvironmentPath = combine cinstEnvironmentPath, + cinstOverwritePolicy = combine cinstOverwritePolicy, + cinstInstallMethod = combine cinstInstallMethod, + cinstInstalldir = combine cinstInstalldir + } + where + combine = combine' savedClientInstallFlags + combinedSavedConfigureFlags = ConfigFlags { configArgs = lastNonEmpty configArgs, configPrograms_ = configPrograms_ . savedConfigureFlags $ b, @@ -296,6 +365,7 @@ configSharedLib = combine configSharedLib, configStaticLib = combine configStaticLib, configDynExe = combine configDynExe, + configFullyStaticExe = combine configFullyStaticExe, configProfExe = combine configProfExe, configProfDetail = combine configProfDetail, configProfLibDetail = combine configProfLibDetail, @@ -343,7 +413,8 @@ configExactConfiguration = combine configExactConfiguration, configFlagError = combine configFlagError, configRelocatable = combine configRelocatable, - configUseResponseFiles = combine configUseResponseFiles + configUseResponseFiles = combine configUseResponseFiles, + configAllowDependingOnPrivateLibs = combine configAllowDependingOnPrivateLibs } where combine = combine' savedConfigureFlags @@ -423,7 +494,22 @@ combine = combine' savedHaddockFlags lastNonEmpty = lastNonEmpty' savedHaddockFlags + combinedSavedTestFlags = TestFlags { + testDistPref = combine testDistPref, + testVerbosity = combine testVerbosity, + testHumanLog = combine testHumanLog, + testMachineLog = combine testMachineLog, + testShowDetails = combine testShowDetails, + testKeepTix = combine testKeepTix, + testWrapper = combine testWrapper, + testFailWhenNoTestSuites = combine testFailWhenNoTestSuites, + testOptions = lastNonEmpty testOptions + } + where + combine = combine' savedTestFlags + lastNonEmpty = lastNonEmpty' savedTestFlags + -- -- * Default config -- @@ -463,11 +549,11 @@ -- initialSavedConfig :: IO SavedConfig initialSavedConfig = do - cacheDir <- defaultCacheDir - logsDir <- defaultLogsDir - worldFile <- defaultWorldFile - extraPath <- defaultExtraPath - symlinkPath <- defaultSymlinkPath + cacheDir <- defaultCacheDir + logsDir <- defaultLogsDir + worldFile <- defaultWorldFile + extraPath <- defaultExtraPath + installPath <- defaultInstallPath return mempty { savedGlobalFlags = mempty { globalCacheDir = toFlag cacheDir, @@ -480,8 +566,10 @@ savedInstallFlags = mempty { installSummaryFile = toNubList [toPathTemplate (logsDir "build.log")], installBuildReports= toFlag AnonymousReports, - installNumJobs = toFlag Nothing, - installSymlinkBinDir = toFlag symlinkPath + installNumJobs = toFlag Nothing + }, + savedClientInstallFlags = mempty { + cinstInstalldir = toFlag installPath } } @@ -521,8 +609,8 @@ dir <- getCabalDir return [dir "bin"] -defaultSymlinkPath :: IO FilePath -defaultSymlinkPath = do +defaultInstallPath :: IO FilePath +defaultInstallPath = do dir <- getCabalDir return (dir "bin") @@ -733,7 +821,16 @@ savedGlobalFlags = defaultGlobalFlags { globalRemoteRepos = toNubList [defaultRemoteRepo] }, + savedInitFlags = mempty { + IT.interactive = toFlag False, + IT.cabalVersion = toFlag (mkVersion [1,10]), + IT.language = toFlag Haskell2010, + IT.license = toFlag BSD3, + IT.sourceDirs = Nothing, + IT.applicationDirs = Nothing + }, savedInstallFlags = defaultInstallFlags, + savedClientInstallFlags= defaultClientInstallFlags, savedConfigureExFlags = defaultConfigExFlags { configAllowNewer = Just (AllowNewer mempty), configAllowOlder = Just (AllowOlder mempty) @@ -745,8 +842,8 @@ savedGlobalInstallDirs = fmap toFlag globalInstallDirs, savedUploadFlags = commandDefaultFlags uploadCommand, savedReportFlags = commandDefaultFlags reportCommand, - savedHaddockFlags = defaultHaddockFlags - + savedHaddockFlags = defaultHaddockFlags, + savedTestFlags = defaultTestFlags } conf1 <- extendToEffectiveConfig conf0 let globalFlagsConf1 = savedGlobalFlags conf1 @@ -856,6 +953,10 @@ (installOptions ParseArgs) ["dry-run", "only", "only-dependencies", "dependencies-only"] [] + ++ toSavedConfig liftClientInstallFlag + (clientInstallOptions ParseArgs) + [] [] + ++ toSavedConfig liftUploadFlag (commandOptions uploadCommand ParseArgs) ["verbose", "check", "documentation", "publish"] [] @@ -963,6 +1064,10 @@ liftInstallFlag = liftField savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags }) +liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig +liftClientInstallFlag = liftField + savedClientInstallFlags (\flags conf -> conf { savedClientInstallFlags = flags }) + liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig liftUploadFlag = liftField savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags }) @@ -979,11 +1084,12 @@ fields <- readFields str let (knownSections, others) = partition isKnownSection fields config <- parse others - let user0 = savedUserInstallDirs config + let init0 = savedInitFlags config + user0 = savedUserInstallDirs config global0 = savedGlobalInstallDirs config - (remoteRepoSections0, haddockFlags, user, global, paths, args) <- + (remoteRepoSections0, haddockFlags, initFlags, user, global, paths, args) <- foldM parseSections - ([], savedHaddockFlags config, user0, global0, [], []) + ([], savedHaddockFlags config, init0, user0, global0, [], []) knownSections let remoteRepoSections = @@ -991,7 +1097,7 @@ . nubBy ((==) `on` remoteRepoName) $ remoteRepoSections0 - return config { + return . fixConfigMultilines $ config { savedGlobalFlags = (savedGlobalFlags config) { globalRemoteRepos = toNubList remoteRepoSections, -- the global extra prog path comes from the configure flag prog path @@ -1002,6 +1108,7 @@ configProgramArgs = args }, savedHaddockFlags = haddockFlags, + savedInitFlags = initFlags, savedUserInstallDirs = user, savedGlobalInstallDirs = global } @@ -1010,15 +1117,38 @@ isKnownSection (ParseUtils.Section _ "repository" _ _) = True isKnownSection (ParseUtils.F _ "remote-repo" _) = True isKnownSection (ParseUtils.Section _ "haddock" _ _) = True + isKnownSection (ParseUtils.Section _ "init" _ _) = True isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True isKnownSection _ = False + -- attempt to split fields that can represent lists of paths into actual lists + -- on failure, leave the field untouched + splitMultiPath :: [String] -> [String] + splitMultiPath [s] = case runP 0 "" (parseOptCommaList parseTokenQ) s of + ParseOk _ res -> res + _ -> [s] + splitMultiPath xs = xs + + -- This is a fixup, pending a full config parser rewrite, to ensure that + -- config fields which can be comma seperated lists actually parse as comma seperated lists + fixConfigMultilines conf = conf { + savedConfigureFlags = + let scf = savedConfigureFlags conf + in scf { + configProgramPathExtra = toNubList $ splitMultiPath (fromNubList $ configProgramPathExtra scf) + , configExtraLibDirs = splitMultiPath (configExtraLibDirs scf) + , configExtraFrameworkDirs = splitMultiPath (configExtraFrameworkDirs scf) + , configExtraIncludeDirs = splitMultiPath (configExtraIncludeDirs scf) + , configConfigureArgs = splitMultiPath (configConfigureArgs scf) + } + } + parse = parseFields (configFieldDescriptions src ++ deprecatedFieldDescriptions) initial - parseSections (rs, h, u, g, p, a) + parseSections (rs, h, i, u, g, p, a) (ParseUtils.Section _ "repository" name fs) = do r' <- parseFields remoteRepoFields (emptyRemoteRepo name) fs when (remoteRepoKeyThreshold r' > length (remoteRepoRootKeys r')) $ @@ -1028,42 +1158,51 @@ && remoteRepoSecure r' /= Just True) $ warning $ "'root-keys' for repository " ++ show (remoteRepoName r') ++ " non-empty, but 'secure' not set to True." - return (r':rs, h, u, g, p, a) + return (r':rs, h, i, u, g, p, a) - parseSections (rs, h, u, g, p, a) + parseSections (rs, h, i, u, g, p, a) (ParseUtils.F lno "remote-repo" raw) = do let mr' = readRepo raw r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr' - return (r':rs, h, u, g, p, a) + return (r':rs, h, i, u, g, p, a) - parseSections accum@(rs, h, u, g, p, a) + parseSections accum@(rs, h, i, u, g, p, a) (ParseUtils.Section _ "haddock" name fs) | name == "" = do h' <- parseFields haddockFlagsFields h fs - return (rs, h', u, g, p, a) + return (rs, h', i, u, g, p, a) | otherwise = do warning "The 'haddock' section should be unnamed" return accum - parseSections accum@(rs, h, u, g, p, a) + + parseSections accum@(rs, h, i, u, g, p, a) + (ParseUtils.Section _ "init" name fs) + | name == "" = do i' <- parseFields initFlagsFields i fs + return (rs, h, i', u, g, p, a) + | otherwise = do + warning "The 'init' section should be unnamed" + return accum + + parseSections accum@(rs, h, i, u, g, p, a) (ParseUtils.Section _ "install-dirs" name fs) | name' == "user" = do u' <- parseFields installDirsFields u fs - return (rs, h, u', g, p, a) + return (rs, h, i, u', g, p, a) | name' == "global" = do g' <- parseFields installDirsFields g fs - return (rs, h, u, g', p, a) + return (rs, h, i, u, g', p, a) | otherwise = do warning "The 'install-paths' section should be for 'user' or 'global'" return accum where name' = lowercase name - parseSections accum@(rs, h, u, g, p, a) + parseSections accum@(rs, h, i, u, g, p, a) (ParseUtils.Section _ "program-locations" name fs) | name == "" = do p' <- parseFields withProgramsFields p fs - return (rs, h, u, g, p', a) + return (rs, h, i, u, g, p', a) | otherwise = do warning "The 'program-locations' section should be unnamed" return accum - parseSections accum@(rs, h, u, g, p, a) + parseSections accum@(rs, h, i, u, g, p, a) (ParseUtils.Section _ "program-default-options" name fs) | name == "" = do a' <- parseFields withProgramOptionsFields a fs - return (rs, h, u, g, p, a') + return (rs, h, i, u, g, p, a') | otherwise = do warning "The 'program-default-options' section should be unnamed" return accum @@ -1087,6 +1226,9 @@ $+$ ppSection "haddock" "" haddockFlagsFields (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals) $+$ Disp.text "" + $+$ ppSection "init" "" initFlagsFields + (fmap savedInitFlags mcomment) (savedInitFlags vals) + $+$ Disp.text "" $+$ installDirsSection "user" savedUserInstallDirs $+$ Disp.text "" $+$ installDirsSection "global" savedGlobalInstallDirs @@ -1160,6 +1302,22 @@ , name `notElem` exclusions ] where exclusions = ["verbose", "builddir", "for-hackage"] + +-- | Fields for the 'init' section. +initFlagsFields :: [FieldDescr IT.InitFlags] +initFlagsFields = [ field + | opt <- initOptions ParseArgs + , let field = viewAsFieldDescr opt + name = fieldName field + , name `notElem` exclusions ] + where + exclusions = + ["author", "email", "quiet", "no-comments", "minimal", "overwrite", + "package-dir", "packagedir", "package-name", "version", "homepage", + "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe", + "simple", "main-is", "expose-module", "exposed-modules", "extension", + "dependency", "build-tool", "with-compiler", + "verbose"] -- | Fields for the 'program-locations' section. withProgramsFields :: [FieldDescr [(String, FilePath)]] diff --git a/Distribution/Client/Configure.hs b/Distribution/Client/Configure.hs --- a/Distribution/Client/Configure.hs +++ b/Distribution/Client/Configure.hs @@ -63,7 +63,11 @@ import Distribution.Package ( Package(..), packageName, PackageId ) import Distribution.Types.Dependency - ( Dependency(..), thisPackageVersion ) + ( thisPackageVersion ) +import Distribution.Types.GivenComponent + ( GivenComponent(..) ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint(..) ) import qualified Distribution.PackageDescription as PkgDesc import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) @@ -77,7 +81,7 @@ , defaultPackageDesc ) import Distribution.System ( Platform ) -import Distribution.Text ( display ) +import Distribution.Deprecated.Text ( display ) import Distribution.Verbosity as Verbosity ( Verbosity ) @@ -254,7 +258,9 @@ -- Return the setup dependencies computed by the solver ReadyPackage cpkg <- mpkg return [ ( cid, srcid ) - | ConfiguredId srcid (Just PkgDesc.CLibName) cid <- CD.setupDeps (confPkgDeps cpkg) + | ConfiguredId srcid + (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) cid + <- CD.setupDeps (confPkgDeps cpkg) ] -- | Warn if any constraints or preferences name packages that are not in the @@ -275,7 +281,7 @@ where unknownConstraints = filter (unknown . userConstraintPackageName . fst) $ configExConstraints flags - unknownPreferences = filter (unknown . \(Dependency name _) -> name) $ + unknownPreferences = filter (unknown . \(PackageVersionConstraint name _) -> name) $ configPreferences flags unknown pkg = null (lookupPackageName installedPkgIndex pkg) && not (elemByPackageName sourcePkgIndex pkg) @@ -322,7 +328,7 @@ . addPreferences -- preferences from the config file or command line [ PackageVersionPreference name ver - | Dependency name ver <- configPreferences configExFlags ] + | PackageVersionConstraint name ver <- configPreferences configExFlags ] . addConstraints -- version constraints from the config file or command line @@ -401,9 +407,11 @@ -- deps. In the end only one set gets passed to Setup.hs configure, -- depending on the Cabal version we are talking to. configConstraints = [ thisPackageVersion srcid - | ConfiguredId srcid (Just PkgDesc.CLibName) _uid <- CD.nonSetupDeps deps ], - configDependencies = [ (packageName srcid, uid) - | ConfiguredId srcid (Just PkgDesc.CLibName) uid <- CD.nonSetupDeps deps ], + | ConfiguredId srcid (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) _uid + <- CD.nonSetupDeps deps ], + configDependencies = [ GivenComponent (packageName srcid) cname uid + | ConfiguredId srcid (Just (PkgDesc.CLibName cname)) uid + <- CD.nonSetupDeps deps ], -- Use '--exact-configuration' if supported. configExactConfiguration = toFlag True, configVerbosity = toFlag verbosity, diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs --- a/Distribution/Client/Dependency.hs +++ b/Distribution/Client/Dependency.hs @@ -47,11 +47,13 @@ setPreferenceDefault, setReorderGoals, setCountConflicts, + setMinimizeConflictSet, setIndependentGoals, setAvoidReinstalls, setShadowPkgs, setStrongFlags, setAllowBootLibInstalls, + setOnlyConstrained, setMaxBackjumps, setEnableBackjumping, setSolveExecutables, @@ -102,7 +104,7 @@ ( comparing ) import Distribution.Simple.Setup ( asBool ) -import Distribution.Text +import Distribution.Deprecated.Text ( display ) import Distribution.Verbosity ( normal, Verbosity ) @@ -157,6 +159,7 @@ depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage, depResolverReorderGoals :: ReorderGoals, depResolverCountConflicts :: CountConflicts, + depResolverMinimizeConflictSet :: MinimizeConflictSet, depResolverIndependentGoals :: IndependentGoals, depResolverAvoidReinstalls :: AvoidReinstalls, depResolverShadowPkgs :: ShadowPkgs, @@ -165,6 +168,10 @@ -- | Whether to allow base and its dependencies to be installed. depResolverAllowBootLibInstalls :: AllowBootLibInstalls, + -- | Whether to only allow explicitly constrained packages plus + -- goals or to allow any package. + depResolverOnlyConstrained :: OnlyConstrained, + depResolverMaxBackjumps :: Maybe Int, depResolverEnableBackjumping :: EnableBackjumping, -- | Whether or not to solve for dependencies on executables. @@ -190,11 +197,13 @@ ++ "\nstrategy: " ++ show (depResolverPreferenceDefault p) ++ "\nreorder goals: " ++ show (asBool (depResolverReorderGoals p)) ++ "\ncount conflicts: " ++ show (asBool (depResolverCountConflicts p)) + ++ "\nminimize conflict set: " ++ show (asBool (depResolverMinimizeConflictSet p)) ++ "\nindependent goals: " ++ show (asBool (depResolverIndependentGoals p)) ++ "\navoid reinstalls: " ++ show (asBool (depResolverAvoidReinstalls p)) ++ "\nshadow packages: " ++ show (asBool (depResolverShadowPkgs p)) ++ "\nstrong flags: " ++ show (asBool (depResolverStrongFlags p)) ++ "\nallow boot library installs: " ++ show (asBool (depResolverAllowBootLibInstalls p)) + ++ "\nonly constrained packages: " ++ show (depResolverOnlyConstrained p) ++ "\nmax backjumps: " ++ maybe "infinite" show (depResolverMaxBackjumps p) where @@ -245,11 +254,13 @@ depResolverSourcePkgIndex = sourcePkgIndex, depResolverReorderGoals = ReorderGoals False, depResolverCountConflicts = CountConflicts True, + depResolverMinimizeConflictSet = MinimizeConflictSet False, depResolverIndependentGoals = IndependentGoals False, depResolverAvoidReinstalls = AvoidReinstalls False, depResolverShadowPkgs = ShadowPkgs False, depResolverStrongFlags = StrongFlags False, depResolverAllowBootLibInstalls = AllowBootLibInstalls False, + depResolverOnlyConstrained = OnlyConstrainedNone, depResolverMaxBackjumps = Nothing, depResolverEnableBackjumping = EnableBackjumping True, depResolverSolveExecutables = SolveExecutables True, @@ -299,6 +310,12 @@ depResolverCountConflicts = count } +setMinimizeConflictSet :: MinimizeConflictSet -> DepResolverParams -> DepResolverParams +setMinimizeConflictSet minimize params = + params { + depResolverMinimizeConflictSet = minimize + } + setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams setIndependentGoals indep params = params { @@ -329,6 +346,12 @@ depResolverAllowBootLibInstalls = i } +setOnlyConstrained :: OnlyConstrained -> DepResolverParams -> DepResolverParams +setOnlyConstrained i params = + params { + depResolverOnlyConstrained = i + } + setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams setMaxBackjumps n params = params { @@ -459,8 +482,8 @@ relaxPackageDeps relKind RelaxDepsAll gpd = PD.transformAllBuildDepends relaxAll gpd where relaxAll :: Dependency -> Dependency - relaxAll (Dependency pkgName verRange) = - Dependency pkgName (removeBound relKind RelaxDepModNone verRange) + relaxAll (Dependency pkgName verRange cs) = + Dependency pkgName (removeBound relKind RelaxDepModNone verRange) cs relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd = PD.transformAllBuildDepends relaxSome gpd @@ -480,13 +503,13 @@ | otherwise -> Nothing relaxSome :: Dependency -> Dependency - relaxSome d@(Dependency depName verRange) + relaxSome d@(Dependency depName verRange cs) | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax = -- a '*'-subject acts absorbing, for consistency with -- the 'Semigroup RelaxDeps' instance - Dependency depName (removeBound relKind relMod verRange) + Dependency depName (removeBound relKind relMod verRange) cs | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax = - Dependency depName (removeBound relKind relMod verRange) + Dependency depName (removeBound relKind relMod verRange) cs | otherwise = d -- no-op -- | Internal helper for 'relaxPackageDeps' @@ -612,7 +635,7 @@ -- | The policy used by all the standard commands, install, fetch, freeze etc --- (but not the new-build and related commands). +-- (but not the v2-build and related commands). -- -- It extends the 'basicInstallPolicy' with a policy on setup deps. -- @@ -632,7 +655,7 @@ mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency] mkDefaultSetupDeps srcpkg | affected = Just [Dependency (mkPackageName "Cabal") - (orLaterVersion $ mkVersion [1,24])] + (orLaterVersion $ mkVersion [1,24]) (Set.singleton PD.LMainLibName)] | otherwise = Nothing where gpkgdesc = packageDescription srcpkg @@ -732,9 +755,8 @@ Step (showDepResolverParams finalparams) $ fmap (validateSolverResult platform comp indGoals) - $ runSolver solver (SolverConfig reordGoals cntConflicts - indGoals noReinstalls - shadowing strFlags allowBootLibs maxBkjumps enableBj + $ runSolver solver (SolverConfig reordGoals cntConflicts minimize indGoals noReinstalls + shadowing strFlags allowBootLibs onlyConstrained_ maxBkjumps enableBj solveExes order verbosity (PruneAfterFirstSuccess False)) platform comp installedPkgIndex sourcePkgIndex pkgConfigDB preferences constraints targets @@ -747,11 +769,13 @@ sourcePkgIndex reordGoals cntConflicts + minimize indGoals noReinstalls shadowing strFlags allowBootLibs + onlyConstrained_ maxBkjumps enableBj solveExes @@ -929,10 +953,10 @@ packageSatisfiesDependency (PackageIdentifier name version) - (Dependency name' versionRange) = assert (name == name') $ + (Dependency name' versionRange _) = assert (name == name') $ version `withinRange` versionRange - dependencyName (Dependency name _) = name + dependencyName (Dependency name _ _) = name mergedDeps :: [MergeResult Dependency PackageId] mergedDeps = mergeDeps requiredDeps (CD.flatDeps specifiedDeps) @@ -991,9 +1015,10 @@ -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] resolveWithoutDependencies (DepResolverParams targets constraints prefs defpref installedPkgIndex sourcePkgIndex - _reorderGoals _countConflicts _indGoals _avoidReinstalls - _shadowing _strFlags _maxBjumps _enableBj - _solveExes _allowBootLibInstalls _order _verbosity) = + _reorderGoals _countConflicts _minimizeConflictSet + _indGoals _avoidReinstalls _shadowing _strFlags + _maxBjumps _enableBj _solveExes + _allowBootLibInstalls _onlyConstrained _order _verbosity) = collectEithers $ map selectPackage (Set.toList targets) where selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage @@ -1004,9 +1029,9 @@ where -- Constraints requiredVersions = packageConstraints pkgname - pkgDependency = Dependency pkgname requiredVersions choices = PackageIndex.lookupDependency sourcePkgIndex - pkgDependency + pkgname + requiredVersions -- Preferences PackagePreferences preferredVersions preferInstalled _ diff --git a/Distribution/Client/Dependency/Types.hs b/Distribution/Client/Dependency/Types.hs --- a/Distribution/Client/Dependency/Types.hs +++ b/Distribution/Client/Dependency/Types.hs @@ -10,9 +10,9 @@ import Data.Char ( isAlpha, toLower ) -import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Deprecated.ReadP as Parse ( pfail, munch1 ) -import Distribution.Text +import Distribution.Deprecated.Text ( Text(..) ) import Text.PrettyPrint diff --git a/Distribution/Client/DistDirLayout.hs b/Distribution/Client/DistDirLayout.hs --- a/Distribution/Client/DistDirLayout.hs +++ b/Distribution/Client/DistDirLayout.hs @@ -27,15 +27,14 @@ import Distribution.Package ( PackageId, ComponentId, UnitId ) -import Distribution.Client.Setup - ( ArchiveFormat(..) ) import Distribution.Compiler import Distribution.Simple.Compiler ( PackageDB(..), PackageDBStack, OptimisationLevel(..) ) -import Distribution.Text +import Distribution.Deprecated.Text import Distribution.Pretty ( prettyShow ) import Distribution.Types.ComponentName +import Distribution.Types.LibraryName import Distribution.System @@ -114,7 +113,7 @@ distPackageCacheDirectory :: DistDirParams -> FilePath, -- | The location that sdists are placed by default. - distSdistFile :: PackageId -> ArchiveFormat -> FilePath, + distSdistFile :: PackageId -> FilePath, distSdistDirectory :: FilePath, distTempDirectory :: FilePath, @@ -199,8 +198,8 @@ display (distParamPackageId params) (case distParamComponentName params of Nothing -> "" - Just CLibName -> "" - Just (CSubLibName name) -> "l" display name + Just (CLibName LMainLibName) -> "" + Just (CLibName (LSubLibName name)) -> "l" display name Just (CFLibName name) -> "f" display name Just (CExeName name) -> "x" display name Just (CTestName name) -> "t" display name @@ -226,12 +225,8 @@ distPackageCacheDirectory params = distBuildDirectory params "cache" distPackageCacheFile params name = distPackageCacheDirectory params name - distSdistFile pid format = distSdistDirectory prettyShow pid <.> ext - where - ext = case format of - TargzFormat -> "tar.gz" - ZipFormat -> "zip" - + distSdistFile pid = distSdistDirectory prettyShow pid <.> "tar.gz" + distSdistDirectory = distDirectory "sdist" distTempDirectory = distDirectory "tmp" diff --git a/Distribution/Client/Fetch.hs b/Distribution/Client/Fetch.hs --- a/Distribution/Client/Fetch.hs +++ b/Distribution/Client/Fetch.hs @@ -44,7 +44,7 @@ ( die', notice, debug ) import Distribution.System ( Platform ) -import Distribution.Text +import Distribution.Deprecated.Text ( display ) import Distribution.Verbosity ( Verbosity ) @@ -162,12 +162,16 @@ . setCountConflicts countConflicts + . setMinimizeConflictSet minimizeConflictSet + . setShadowPkgs shadowPkgs . setStrongFlags strongFlags . setAllowBootLibInstalls allowBootLibInstalls + . setOnlyConstrained onlyConstrained + . setSolverVerbosity verbosity . addConstraints @@ -195,11 +199,13 @@ reorderGoals = fromFlag (fetchReorderGoals fetchFlags) countConflicts = fromFlag (fetchCountConflicts fetchFlags) + minimizeConflictSet = fromFlag (fetchMinimizeConflictSet fetchFlags) independentGoals = fromFlag (fetchIndependentGoals fetchFlags) shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags) strongFlags = fromFlag (fetchStrongFlags fetchFlags) maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags) allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls fetchFlags) + onlyConstrained = fromFlag (fetchOnlyConstrained fetchFlags) checkTarget :: Verbosity -> UserTarget -> IO () diff --git a/Distribution/Client/FetchUtils.hs b/Distribution/Client/FetchUtils.hs --- a/Distribution/Client/FetchUtils.hs +++ b/Distribution/Client/FetchUtils.hs @@ -41,7 +41,7 @@ ( PackageId, packageName, packageVersion ) import Distribution.Simple.Utils ( notice, info, debug, die' ) -import Distribution.Text +import Distribution.Deprecated.Text ( display ) import Distribution.Verbosity ( Verbosity, verboseUnmarkOutput ) diff --git a/Distribution/Client/Freeze.hs b/Distribution/Client/Freeze.hs --- a/Distribution/Client/Freeze.hs +++ b/Distribution/Client/Freeze.hs @@ -55,7 +55,7 @@ ( die', notice, debug, writeFileAtomic ) import Distribution.System ( Platform ) -import Distribution.Text +import Distribution.Deprecated.Text ( display ) import Distribution.Verbosity ( Verbosity ) @@ -175,12 +175,16 @@ . setCountConflicts countConflicts + . setMinimizeConflictSet minimizeConflictSet + . setShadowPkgs shadowPkgs . setStrongFlags strongFlags . setAllowBootLibInstalls allowBootLibInstalls + . setOnlyConstrained onlyConstrained + . setSolverVerbosity verbosity . addConstraints @@ -203,11 +207,13 @@ reorderGoals = fromFlag (freezeReorderGoals freezeFlags) countConflicts = fromFlag (freezeCountConflicts freezeFlags) + minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags) independentGoals = fromFlag (freezeIndependentGoals freezeFlags) shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags) strongFlags = fromFlag (freezeStrongFlags freezeFlags) maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags) allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags) + onlyConstrained = fromFlag (freezeOnlyConstrained freezeFlags) -- | Remove all unneeded packages from an install plan. diff --git a/Distribution/Client/GenBounds.hs b/Distribution/Client/GenBounds.hs --- a/Distribution/Client/GenBounds.hs +++ b/Distribution/Client/GenBounds.hs @@ -45,13 +45,13 @@ ( tryFindPackageDesc ) import Distribution.System ( Platform ) -import Distribution.Text +import Distribution.Deprecated.Text ( display ) import Distribution.Verbosity ( Verbosity ) import Distribution.Version ( Version, alterVersion - , LowerBound(..), UpperBound(..), VersionRange(..), asVersionIntervals + , LowerBound(..), UpperBound(..), VersionRange, asVersionIntervals , orLaterVersion, earlierVersion, intersectVersionRanges ) import System.Directory ( getCurrentDirectory ) @@ -112,7 +112,7 @@ let cinfo = compilerInfo comp cwd <- getCurrentDirectory - path <- tryFindPackageDesc cwd + path <- tryFindPackageDesc verbosity cwd gpd <- readGenericPackageDescription verbosity path -- NB: We don't enable tests or benchmarks, since often they -- don't really have useful bounds. @@ -144,10 +144,10 @@ traverse_ (putStrLn . (++",") . showBounds padTo) thePkgs depName :: Dependency -> String - depName (Dependency pn _) = unPackageName pn + depName (Dependency pn _ _) = unPackageName pn depVersion :: Dependency -> VersionRange - depVersion (Dependency _ vr) = vr + depVersion (Dependency _ vr _) = vr -- | The message printed when some dependencies are found to be lacking proper -- PVP-mandated bounds. diff --git a/Distribution/Client/Get.hs b/Distribution/Client/Get.hs --- a/Distribution/Client/Get.hs +++ b/Distribution/Client/Get.hs @@ -24,7 +24,8 @@ import Prelude () import Distribution.Client.Compat.Prelude hiding (get) - +import Distribution.Compat.Directory + ( listDirectory ) import Distribution.Package ( PackageId, packageId, packageName ) import Distribution.Simple.Setup @@ -33,7 +34,7 @@ ( notice, die', info, writeFileAtomic ) import Distribution.Verbosity ( Verbosity ) -import Distribution.Text (display) +import Distribution.Deprecated.Text (display) import qualified Distribution.PackageDescription as PD import Distribution.Simple.Program ( programName ) @@ -162,12 +163,16 @@ -> PackageDescriptionOverride -> FilePath -> IO () unpackPackage verbosity prefix pkgid descOverride pkgPath = do - let pkgdirname = display pkgid - pkgdir = prefix pkgdirname - pkgdir' = addTrailingPathSeparator pkgdir + let pkgdirname = display pkgid + pkgdir = prefix pkgdirname + pkgdir' = addTrailingPathSeparator pkgdir + emptyDirectory directory = null <$> listDirectory directory existsDir <- doesDirectoryExist pkgdir - when existsDir $ die' verbosity $ - "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking." + when existsDir $ do + isEmpty <- emptyDirectory pkgdir + unless isEmpty $ + die' verbosity $ + "The directory \"" ++ pkgdir' ++ "\" already exists and is not empty, not unpacking." existsFile <- doesFileExist pkgdir when existsFile $ die' verbosity $ "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." diff --git a/Distribution/Client/Glob.hs b/Distribution/Client/Glob.hs --- a/Distribution/Client/Glob.hs +++ b/Distribution/Client/Glob.hs @@ -21,9 +21,9 @@ import Data.List (stripPrefix) import Control.Monad (mapM) -import Distribution.Text -import Distribution.Compat.ReadP (ReadP, (<++), (+++)) -import qualified Distribution.Compat.ReadP as Parse +import Distribution.Deprecated.Text +import Distribution.Deprecated.ReadP (ReadP, (<++), (+++)) +import qualified Distribution.Deprecated.ReadP as Parse import qualified Text.PrettyPrint as Disp import System.FilePath diff --git a/Distribution/Client/HttpUtils.hs b/Distribution/Client/HttpUtils.hs --- a/Distribution/Client/HttpUtils.hs +++ b/Distribution/Client/HttpUtils.hs @@ -36,6 +36,7 @@ import qualified Data.ByteString.Lazy.Char8 as BS import qualified Paths_cabal_install (version) import Distribution.Verbosity (Verbosity) +import Distribution.Pretty (prettyShow) import Distribution.Simple.Utils ( die', info, warn, debug, notice, writeFileAtomic , copyFileVerbose, withTempFile ) @@ -45,8 +46,6 @@ ( RemoteRepo(..) ) import Distribution.System ( buildOS, buildArch ) -import Distribution.Text - ( display ) import qualified System.FilePath.Posix as FilePath.Posix ( splitDirectories ) import System.FilePath @@ -72,6 +71,7 @@ import Numeric (showHex) import System.Random (randomRIO) import System.Exit (ExitCode(..)) +import Data.Version (showVersion) ------------------------------------------------------------------------------ @@ -269,7 +269,7 @@ configureTransport :: Verbosity -> [FilePath] -> Maybe String -> IO HttpTransport configureTransport verbosity extraPath (Just name) = - -- the user secifically selected a transport by name so we'll try and + -- the user specifically selected a transport by name so we'll try and -- configure that one case find (\(name',_,_,_) -> name' == name) supportedTransports of @@ -807,8 +807,8 @@ -- userAgent :: String -userAgent = concat [ "cabal-install/", display Paths_cabal_install.version - , " (", display buildOS, "; ", display buildArch, ")" +userAgent = concat [ "cabal-install/", showVersion Paths_cabal_install.version + , " (", prettyShow buildOS, "; ", prettyShow buildArch, ")" ] statusParseFail :: Verbosity -> URI -> String -> IO a diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs --- a/Distribution/Client/IndexUtils.hs +++ b/Distribution/Client/IndexUtils.hs @@ -67,7 +67,7 @@ ( getInstalledPackages, getInstalledPackagesMonitorFiles ) import Distribution.Version ( Version, mkVersion, intersectVersionRanges ) -import Distribution.Text +import Distribution.Deprecated.Text ( display, simpleParse ) import Distribution.Simple.Utils ( die', warn, info ) @@ -198,7 +198,7 @@ -- it was at a particular time. -- -- TODO: Enhance to allow specifying per-repo 'IndexState's and also --- report back per-repo 'IndexStateInfo's (in order for @new-freeze@ +-- report back per-repo 'IndexStateInfo's (in order for @v2-freeze@ -- to access it) getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> Maybe IndexState -> IO SourcePackageDb @@ -275,7 +275,7 @@ let (pkgs, prefs) = mconcat pkgss prefs' = Map.fromListWith intersectVersionRanges - [ (name, range) | Dependency name range <- prefs ] + [ (name, range) | Dependency name range _ <- prefs ] _ <- evaluate pkgs _ <- evaluate prefs' return SourcePackageDb { @@ -703,7 +703,7 @@ let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno) accum srcpkgs (srcpkg:btrs) prefs entries - accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _) _ _ : entries) = + accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _ _) _ _ : entries) = accum srcpkgs btrs (Map.insert pn pref prefs) entries getEntryContent :: BlockNo -> IO ByteString @@ -866,7 +866,7 @@ = CachePackageId PackageId !BlockNo !Timestamp | CachePreference Dependency !BlockNo !Timestamp | CacheBuildTreeRef !BuildTreeRefType !BlockNo - -- NB: CacheBuildTreeRef is irrelevant for 01-index & new-build + -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build deriving (Eq,Generic) instance NFData IndexCacheEntry where diff --git a/Distribution/Client/IndexUtils/Timestamp.hs b/Distribution/Client/IndexUtils/Timestamp.hs --- a/Distribution/Client/IndexUtils/Timestamp.hs +++ b/Distribution/Client/IndexUtils/Timestamp.hs @@ -32,14 +32,14 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Distribution.Compat.Binary -import qualified Distribution.Compat.ReadP as ReadP -import Distribution.Text +import qualified Distribution.Deprecated.ReadP as ReadP +import Distribution.Deprecated.Text import qualified Text.PrettyPrint as Disp import GHC.Generics (Generic) -- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970). newtype Timestamp = TS Int64 -- Tar.EpochTime - deriving (Eq,Ord,Enum,NFData,Show) + deriving (Eq,Ord,Enum,NFData,Show,Generic) epochTimeToTimestamp :: Tar.EpochTime -> Maybe Timestamp epochTimeToTimestamp et diff --git a/Distribution/Client/Init.hs b/Distribution/Client/Init.hs --- a/Distribution/Client/Init.hs +++ b/Distribution/Client/Init.hs @@ -24,13 +24,15 @@ import Prelude () import Distribution.Client.Compat.Prelude hiding (empty) +import Distribution.Deprecated.ReadP (readP_to_E) + import System.IO ( hSetBuffering, stdout, BufferMode(..) ) import System.Directory ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile , getDirectoryContents, createDirectoryIfMissing ) import System.FilePath - ( (), (<.>), takeBaseName, equalFilePath ) + ( (), (<.>), takeBaseName, takeExtension, equalFilePath ) import Data.Time ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) @@ -39,6 +41,7 @@ import Data.Function ( on ) import qualified Data.Map as M +import qualified Data.Set as Set import Control.Monad ( (>=>), join, forM_, mapM, mapM_ ) import Control.Arrow @@ -53,9 +56,13 @@ ( Verbosity ) import Distribution.ModuleName ( ModuleName ) -- And for the Text instance +import qualified Distribution.ModuleName as ModuleName + ( fromString, toFilePath ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo, exposed ) import qualified Distribution.Package as P +import Distribution.Types.LibraryName + ( LibraryName(..) ) import Language.Haskell.Extension ( Language(..) ) import Distribution.Client.Init.Types @@ -73,7 +80,7 @@ import qualified Distribution.SPDX as SPDX import Distribution.ReadE - ( runReadE, readP_to_E ) + ( runReadE ) import Distribution.Simple.Setup ( Flag(..), flagToMaybe ) import Distribution.Simple.Utils @@ -86,11 +93,11 @@ ( ProgramDb ) import Distribution.Simple.PackageIndex ( InstalledPackageIndex, moduleNameIndex ) -import Distribution.Text +import Distribution.Deprecated.Text ( display, Text(..) ) import Distribution.Pretty ( prettyShow ) -import Distribution.Parsec.Class +import Distribution.Parsec ( eitherParsec ) import Distribution.Solver.Types.PackageIndex @@ -124,8 +131,15 @@ _ -> writeLicense initFlags' writeSetupFile initFlags' writeChangeLog initFlags' - createSourceDirectories initFlags' + createDirectories (sourceDirs initFlags') + createLibHs initFlags' + createDirectories (applicationDirs initFlags') createMainHs initFlags' + -- If a test suite was requested and this is not an executable-only + -- package, then create the "test" directory. + when (eligibleForTestSuite initFlags') $ do + createDirectories (testDirs initFlags') + createTestHs initFlags' success <- writeCabalFile initFlags' when success $ generateWarnings initFlags' @@ -138,7 +152,9 @@ -- user. extendFlags :: InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags extendFlags pkgIx sourcePkgDb = - getCabalVersion + getSimpleProject + >=> getLibOrExec + >=> getCabalVersion >=> getPackageName sourcePkgDb >=> getVersion >=> getLicense @@ -147,8 +163,10 @@ >=> getSynopsis >=> getCategory >=> getExtraSourceFiles - >=> getLibOrExec + >=> getAppDir >=> getSrcDir + >=> getGenTests + >=> getTestDir >=> getLanguage >=> getGenComments >=> getModulesBuildToolsAndDeps pkgIx @@ -178,6 +196,25 @@ [2,4] -> "2.4 (+ support for '**' globbing)" _ -> display v +-- | Ask if a simple project with sensible defaults should be created. +getSimpleProject :: InitFlags -> IO InitFlags +getSimpleProject flags = do + simpleProj <- return (flagToMaybe $ simpleProject flags) + ?>> maybePrompt flags + (promptYesNo + "Should I generate a simple project with sensible defaults" + (Just True)) + return $ case maybeToFlag simpleProj of + Flag True -> + flags { interactive = Flag False + , simpleProject = Flag True + , packageType = Flag LibraryAndExecutable + , cabalVersion = Flag (mkVersion [2,4]) + } + simpleProjFlag@_ -> + flags { simpleProject = simpleProjFlag } + + -- | Ask which version of the cabal spec to use. getCabalVersion :: InitFlags -> IO InitFlags getCabalVersion flags = do @@ -355,11 +392,13 @@ getLibOrExec :: InitFlags -> IO InitFlags getLibOrExec flags = do pkgType <- return (flagToMaybe $ packageType flags) - ?>> maybePrompt flags (either (const Library) id `fmap` + ?>> maybePrompt flags (either (const Executable) id `fmap` promptList "What does the package build" - [Library, Executable, LibraryAndExecutable] + [Executable, Library, LibraryAndExecutable] Nothing displayPackageType False) - ?>> return (Just Library) + ?>> return (Just Executable) + + -- If this package contains an executable, get the main file name. mainFile <- if pkgType == Just Library then return Nothing else getMainFile flags @@ -367,6 +406,7 @@ , mainIs = maybeToFlag mainFile } + -- | Try to guess the main file of the executable, and prompt the user to choose -- one of them. Top-level modules including the word 'Main' in the file name -- will be candidates, and shorter filenames will be preferred. @@ -383,6 +423,30 @@ defaultFile showCandidate True) ?>> return (fmap (either id id) defaultFile) +-- | Ask if a test suite should be generated for the library. +getGenTests :: InitFlags -> IO InitFlags +getGenTests flags = do + genTests <- return (flagToMaybe $ initializeTestSuite flags) + -- Only generate a test suite if the package contains a library. + ?>> if (packageType flags) == Flag Executable then return (Just False) else return Nothing + ?>> maybePrompt flags + (promptYesNo + "Should I generate a test suite for the library" + (Just True)) + return $ flags { initializeTestSuite = maybeToFlag genTests } + +-- | Ask for the test root directory. +getTestDir :: InitFlags -> IO InitFlags +getTestDir flags = do + dirs <- return (testDirs flags) + -- Only need testDirs when test suite generation is enabled. + ?>> if not (eligibleForTestSuite flags) then return (Just []) else return Nothing + ?>> fmap (fmap ((:[]) . either id id)) (maybePrompt + flags + (promptList "Test directory" ["test"] (Just "test") id True)) + + return $ flags { testDirs = dirs } + -- | Ask for the base language of the package. getLanguage :: InitFlags -> IO InitFlags getLanguage flags = do @@ -415,14 +479,47 @@ where promptMsg = "Add informative comments to each field in the cabal file (y/n)" --- | Ask for the source root directory. +-- | Ask for the application root directory. +getAppDir :: InitFlags -> IO InitFlags +getAppDir flags = do + appDirs <- return (applicationDirs flags) + -- No application dir if this is a 'Library'. + ?>> if (packageType flags) == Flag Library then return (Just []) else return Nothing + ?>> fmap (:[]) `fmap` guessAppDir flags + ?>> fmap (>>= fmap ((:[]) . either id id)) (maybePrompt + flags + (promptListOptional' + ("Application " ++ mainFile ++ "directory") + ["src-exe", "app"] id)) + + return $ flags { applicationDirs = appDirs } + + where + mainFile = case mainIs flags of + Flag mainPath -> "(" ++ mainPath ++ ") " + _ -> "" + +-- | Try to guess app directory. Could try harder; for the +-- moment just looks to see whether there is a directory called 'app'. +guessAppDir :: InitFlags -> IO (Maybe String) +guessAppDir flags = do + dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags + appIsDir <- doesDirectoryExist (dir "app") + return $ if appIsDir + then Just "app" + else Nothing + +-- | Ask for the source (library) root directory. getSrcDir :: InitFlags -> IO InitFlags getSrcDir flags = do srcDirs <- return (sourceDirs flags) + -- source dir if this is an 'Executable'. + ?>> if (packageType flags) == Flag Executable then return (Just []) else return Nothing ?>> fmap (:[]) `fmap` guessSourceDir flags ?>> fmap (>>= fmap ((:[]) . either id id)) (maybePrompt flags - (promptListOptional' "Source directory" ["src"] id)) + (promptListOptional' "Library source directory" + ["src", "lib", "src-lib"] id)) return $ flags { sourceDirs = srcDirs } @@ -473,7 +570,31 @@ exts <- return (otherExts flags) ?>> (return . Just . nub . concatMap extensions $ sourceFiles) - return $ flags { exposedModules = Just mods + -- If we're initializing a library and there were no modules discovered + -- then create an empty 'MyLib' module. + -- This gets a little tricky when 'sourceDirs' == 'applicationDirs' because + -- then the executable needs to set 'other-modules: MyLib' or else the build + -- fails. + let (finalModsList, otherMods) = case (packageType flags, mods) of + + -- For an executable leave things as they are. + (Flag Executable, _) -> (mods, otherModules flags) + + -- If a non-empty module list exists don't change anything. + (_, (_:_)) -> (mods, otherModules flags) + + -- Library only: 'MyLib' in 'other-modules' only. + (Flag Library, _) -> ([myLibModule], Nothing) + + -- For a 'LibraryAndExecutable' we need to have special handling. + -- If we don't have a module list (Nothing or empty), then create a Lib. + (_, []) -> + if sourceDirs flags == applicationDirs flags + then ([myLibModule], Just [myLibModule]) + else ([myLibModule], Nothing) + + return $ flags { exposedModules = Just finalModsList + , otherModules = otherMods , buildTools = tools , dependencies = deps , otherExts = exts @@ -527,13 +648,14 @@ toDep :: [P.PackageIdentifier] -> IO P.Dependency -- If only one version, easy. We change e.g. 0.4.2 into 0.4.* - toDep [pid] = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) + toDep [pid] = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) (Set.singleton LMainLibName) --TODO sublibraries -- Otherwise, choose the latest version and issue a warning. toDep pids = do message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.") return $ P.Dependency (P.pkgName . head $ pids) (pvpize desugar . maximum . map P.pkgVersion $ pids) + (Set.singleton LMainLibName) --TODO take into account sublibraries -- | Given a version, return an API-compatible (according to PVP) version range. -- @@ -559,17 +681,23 @@ incVersion' m [] = replicate m 0 ++ [1] incVersion' m (v:vs) = v : incVersion' (m-1) vs +-- | Returns true if this package is eligible for test suite initialization. +eligibleForTestSuite :: InitFlags -> Bool +eligibleForTestSuite flags = + Flag True == initializeTestSuite flags + && Flag Executable /= packageType flags + --------------------------------------------------------------------------- -- Prompting/user interaction ------------------------------------------- --------------------------------------------------------------------------- --- | Run a prompt or not based on the nonInteractive flag of the +-- | Run a prompt or not based on the interactive flag of the -- InitFlags structure. maybePrompt :: InitFlags -> IO t -> IO (Maybe t) maybePrompt flags p = - case nonInteractive flags of - Flag True -> return Nothing - _ -> Just `fmap` p + case interactive flags of + Flag True -> Just `fmap` p + _ -> return Nothing -- | Create a prompt with optional default value that returns a -- String. @@ -776,19 +904,49 @@ moveExistingFile flags fileName writeFile fileName content --- | Create source directories, if they were given. -createSourceDirectories :: InitFlags -> IO () -createSourceDirectories flags = case sourceDirs flags of - Just dirs -> forM_ dirs (createDirectoryIfMissing True) - Nothing -> return () +-- | Create directories, if they were given, and don't already exist. +createDirectories :: Maybe [String] -> IO () +createDirectories mdirs = case mdirs of + Just dirs -> forM_ dirs (createDirectoryIfMissing True) + Nothing -> return () +-- | Create MyLib.hs file, if its the only module in the liste. +createLibHs :: InitFlags -> IO () +createLibHs flags = when ((exposedModules flags) == Just [myLibModule]) $ do + let modFilePath = ModuleName.toFilePath myLibModule ++ ".hs" + case sourceDirs flags of + Just (srcPath:_) -> writeLibHs flags (srcPath modFilePath) + _ -> writeLibHs flags modFilePath + +-- | Write a MyLib.hs file if it doesn't already exist. +writeLibHs :: InitFlags -> FilePath -> IO () +writeLibHs flags libPath = do + dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) + let libFullPath = dir libPath + exists <- doesFileExist libFullPath + unless exists $ do + message flags $ "Generating " ++ libPath ++ "..." + writeFileSafe flags libFullPath myLibHs + +myLibModule :: ModuleName +myLibModule = ModuleName.fromString "MyLib" + +-- | Default MyLib.hs file. Used when no Lib.hs exists. +myLibHs :: String +myLibHs = unlines + [ "module MyLib (someFunc) where" + , "" + , "someFunc :: IO ()" + , "someFunc = putStrLn \"someFunc\"" + ] + -- | Create Main.hs, but only if we are init'ing an executable and -- the mainIs flag has been provided. createMainHs :: InitFlags -> IO () createMainHs flags = if hasMainHs flags then - case sourceDirs flags of - Just (srcPath:_) -> writeMainHs flags (srcPath mainFile) + case applicationDirs flags of + Just (appPath:_) -> writeMainHs flags (appPath mainFile) _ -> writeMainHs flags mainFile else return () where @@ -802,7 +960,7 @@ exists <- doesFileExist mainFullPath unless exists $ do message flags $ "Generating " ++ mainPath ++ "..." - writeFileSafe flags mainFullPath mainHs + writeFileSafe flags mainFullPath (mainHs flags) -- | Check that a main file exists. hasMainHs :: InitFlags -> Bool @@ -811,15 +969,68 @@ || packageType flags == Flag LibraryAndExecutable) _ -> False --- | Default Main.hs file. Used when no Main.hs exists. -mainHs :: String -mainHs = unlines - [ "module Main where" +-- | Default Main.(l)hs file. Used when no Main.(l)hs exists. +-- +-- If we are initializing a new 'LibraryAndExecutable' then import 'MyLib'. +mainHs :: InitFlags -> String +mainHs flags = (unlines . map prependPrefix) $ case packageType flags of + Flag LibraryAndExecutable -> + [ "module Main where" + , "" + , "import qualified MyLib (someFunc)" + , "" + , "main :: IO ()" + , "main = do" + , " putStrLn \"Hello, Haskell!\"" + , " MyLib.someFunc" + ] + _ -> + [ "module Main where" + , "" + , "main :: IO ()" + , "main = putStrLn \"Hello, Haskell!\"" + ] + where + prependPrefix "" = "" + prependPrefix line + | isLiterate = "> " ++ line + | otherwise = line + isLiterate = case mainIs flags of + Flag mainPath -> takeExtension mainPath == ".lhs" + _ -> False + +testFile :: String +testFile = "MyLibTest.hs" + +-- | Create MyLibTest.hs, but only if we are init'ing a library and +-- the initializeTestSuite flag has been set. +createTestHs :: InitFlags -> IO () +createTestHs flags = + when (eligibleForTestSuite flags) $ + case testDirs flags of + Just (testPath:_) -> writeTestHs flags (testPath testFile) + _ -> writeMainHs flags testFile + +--- | Write a test file. +writeTestHs :: InitFlags -> FilePath -> IO () +writeTestHs flags testPath = do + dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) + let testFullPath = dir testPath + exists <- doesFileExist testFullPath + unless exists $ do + message flags $ "Generating " ++ testPath ++ "..." + writeFileSafe flags testFullPath testHs + +-- | Default MyLibTest.hs file. +testHs :: String +testHs = unlines + [ "module Main (main) where" , "" , "main :: IO ()" - , "main = putStrLn \"Hello, Haskell!\"" + , "main = putStrLn \"Test suite not yet implemented.\"" ] + -- | Move an existing file, if there is one, and the overwrite flag is -- not set. moveExistingFile :: InitFlags -> FilePath -> IO () @@ -934,6 +1145,8 @@ Flag Library -> libraryStanza Flag LibraryAndExecutable -> libraryStanza $+$ executableStanza _ -> empty + + , if eligibleForTestSuite c then testSuiteStanza else empty ] where specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c) @@ -946,7 +1159,7 @@ generateBuildInfo :: BuildType -> InitFlags -> Doc generateBuildInfo buildType c' = vcat - [ fieldS "other-modules" (listField (otherModules c')) + [ fieldS "other-modules" (listField otherMods) (Just $ case buildType of LibBuild -> "Modules included in this library but not exported." ExecBuild -> "Modules included in this executable, other than Main.") @@ -956,11 +1169,13 @@ (Just "LANGUAGE extensions used by modules in this package.") True - , fieldS "build-depends" (listField (dependencies c')) + , fieldS "build-depends" ((++ myLibDep) <$> listField (dependencies c')) (Just "Other library packages from which modules are imported.") True - , fieldS "hs-source-dirs" (listFieldS (sourceDirs c')) + , fieldS "hs-source-dirs" (listFieldS (case buildType of + LibBuild -> sourceDirs c' + ExecBuild -> applicationDirs c')) (Just "Directories containing source files.") True @@ -972,7 +1187,20 @@ (Just "Base language which the package is written in.") True ] + -- Hack: Can't construct a 'Dependency' which is just 'packageName'(?). + where + myLibDep = if exposedModules c' == Just [myLibModule] && buildType == ExecBuild + then case packageName c' of + Flag pkgName -> ", " ++ P.unPackageName pkgName + _ -> "" + else "" + -- Only include 'MyLib' in 'other-modules' of the executable. + otherModsFromFlag = otherModules c' + otherMods = if buildType == LibBuild && otherModsFromFlag == Just [myLibModule] + then Nothing + else otherModsFromFlag + listField :: Text s => Maybe [s] -> Flag String listField = listFieldS . fmap (map display) @@ -1041,6 +1269,30 @@ , generateBuildInfo LibBuild c ]) + testSuiteStanza :: Doc + testSuiteStanza = text "\ntest-suite" <+> + text (maybe "" ((++"-test") . display) . flagToMaybe $ packageName c) $$ + nest 2 (vcat + [ field "default-language" (language c) + (Just "Base language which the package is written in.") + True + + , fieldS "type" (Flag "exitcode-stdio-1.0") + (Just "The interface type and version of the test suite.") + True + + , fieldS "hs-source-dirs" (listFieldS (testDirs c)) + (Just "The directory where the test specifications are found.") + True + + , fieldS "main-is" (Flag testFile) + (Just "The entrypoint to the test suite.") + True + + , fieldS "build-depends" (listField (dependencies c)) + (Just "Test dependencies.") + True + ]) -- | Generate warnings for missing fields etc. generateWarnings :: InitFlags -> IO () diff --git a/Distribution/Client/Init/Heuristics.hs b/Distribution/Client/Init/Heuristics.hs --- a/Distribution/Client/Init/Heuristics.hs +++ b/Distribution/Client/Init/Heuristics.hs @@ -23,7 +23,7 @@ import Prelude () import Distribution.Client.Compat.Prelude -import Distribution.Text (simpleParse) +import Distribution.Parsec (simpleParsec) import Distribution.Simple.Setup (Flag(..), flagToMaybe) import Distribution.ModuleName ( ModuleName, toFilePath ) @@ -147,7 +147,7 @@ where relRoot = makeRelative projectRoot srcRoot unqualModName = dropExtension entry - modName = simpleParse + modName = simpleParsec $ intercalate "." . reverse $ (unqualModName : hierarchy) ext = case takeExtension entry of '.':e -> e; e -> e scanRecursive parent hierarchy entry @@ -179,7 +179,7 @@ -- minimum. -- A poor man's LANGUAGE pragma parser. - exts = mapMaybe simpleParse + exts = mapMaybe simpleParsec . concatMap getPragmas . filter isLANGUAGEPragma . map fst @@ -205,7 +205,7 @@ where getModName :: [String] -> Maybe ModuleName getModName [] = Nothing getModName ("qualified":ws) = getModName ws - getModName (ms:_) = simpleParse ms + getModName (ms:_) = simpleParsec ms diff --git a/Distribution/Client/Init/Types.hs b/Distribution/Client/Init/Types.hs --- a/Distribution/Client/Init/Types.hs +++ b/Distribution/Client/Init/Types.hs @@ -28,8 +28,8 @@ import Language.Haskell.Extension ( Language(..), Extension ) import qualified Text.PrettyPrint as Disp -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Text +import qualified Distribution.Deprecated.ReadP as Parse +import Distribution.Deprecated.Text import GHC.Generics ( Generic ) @@ -39,11 +39,12 @@ -- likely to want and/or that we are likely to be able to -- intelligently guess. data InitFlags = - InitFlags { nonInteractive :: Flag Bool + InitFlags { interactive :: Flag Bool , quiet :: Flag Bool , packageDir :: Flag FilePath , noComments :: Flag Bool , minimal :: Flag Bool + , simpleProject :: Flag Bool , packageName :: Flag P.PackageName , version :: Flag Version @@ -65,10 +66,14 @@ , otherModules :: Maybe [ModuleName] , otherExts :: Maybe [Extension] - , dependencies :: Maybe [P.Dependency] - , sourceDirs :: Maybe [String] - , buildTools :: Maybe [String] + , dependencies :: Maybe [P.Dependency] + , applicationDirs :: Maybe [String] + , sourceDirs :: Maybe [String] + , buildTools :: Maybe [String] + , initializeTestSuite :: Flag Bool + , testDirs :: Maybe [String] + , initHcPath :: Flag FilePath , initVerbosity :: Flag Verbosity @@ -81,7 +86,9 @@ -- not Flag [foo]. data BuildType = LibBuild | ExecBuild + deriving Eq +-- The type of package to initialize. data PackageType = Library | Executable | LibraryAndExecutable deriving (Show, Read, Eq) @@ -120,4 +127,3 @@ instance Text Category where disp = Disp.text . show parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ] -- TODO: eradicateNoParse - diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -78,7 +78,8 @@ import Distribution.Client.Setup ( GlobalFlags(..), RepoContext(..) , ConfigFlags(..), configureCommand, filterConfigureFlags - , ConfigExFlags(..), InstallFlags(..) ) + , ConfigExFlags(..), InstallFlags(..) + , filterTestFlags ) import Distribution.Client.Config ( getCabalDir, defaultUserInstall ) import Distribution.Client.Sandbox.Timestamp @@ -123,12 +124,13 @@ import Distribution.Simple.Setup ( haddockCommand, HaddockFlags(..) , buildCommand, BuildFlags(..), emptyBuildFlags + , TestFlags , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) import qualified Distribution.Simple.Setup as Cabal ( Flag(..) , copyCommand, CopyFlags(..), emptyCopyFlags , registerCommand, RegisterFlags(..), emptyRegisterFlags - , testCommand, TestFlags(..), emptyTestFlags ) + , testCommand, TestFlags(..) ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, comparing , writeFileAtomic, withUTF8FileContents ) @@ -142,7 +144,12 @@ , Package(..), HasMungedPackageId(..), HasUnitId(..) , UnitId ) import Distribution.Types.Dependency - ( Dependency(..), thisPackageVersion ) + ( thisPackageVersion ) +import Distribution.Types.GivenComponent + ( GivenComponent(..) ) +import Distribution.Pretty ( prettyShow ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint(..) ) import Distribution.Types.MungedPackageId import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription @@ -151,8 +158,6 @@ , showFlagValue, diffFlagAssignment, nullFlagAssignment ) import Distribution.PackageDescription.Configuration ( finalizePD ) -import Distribution.ParseUtils - ( showPWarning ) import Distribution.Version ( Version, VersionRange, foldVersionRange ) import Distribution.Simple.Utils as Utils @@ -163,8 +168,6 @@ , tryCanonicalizePath, ProgressPhase(..), progressMessage ) import Distribution.System ( Platform, OS(Windows), buildOS, buildPlatform ) -import Distribution.Text - ( display ) import Distribution.Verbosity as Verbosity ( Verbosity, modifyVerbosity, normal, verbose ) import Distribution.Simple.BuildPaths ( exeExtension ) @@ -201,10 +204,11 @@ -> ConfigExFlags -> InstallFlags -> HaddockFlags + -> TestFlags -> [UserTarget] -> IO () install verbosity packageDBs repos comp platform progdb useSandbox mSandboxPkgInfo - globalFlags configFlags configExFlags installFlags haddockFlags + globalFlags configFlags configExFlags installFlags haddockFlags testFlags userTargets0 = do unless (installRootCmd installFlags == Cabal.NoFlag) $ @@ -233,7 +237,7 @@ args :: InstallArgs args = (packageDBs, repos, comp, platform, progdb, useSandbox, mSandboxPkgInfo, globalFlags, configFlags, configExFlags, - installFlags, haddockFlags) + installFlags, haddockFlags, testFlags) die'' message = die' verbosity (message ++ if isUseSandbox useSandbox then installFailedInSandbox else []) @@ -266,14 +270,15 @@ , ConfigFlags , ConfigExFlags , InstallFlags - , HaddockFlags ) + , HaddockFlags + , TestFlags ) -- | Make an install context given install arguments. makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget] -> IO InstallContext makeInstallContext verbosity (packageDBs, repoCtxt, comp, _, progdb,_,_, - globalFlags, _, configExFlags, installFlags, _) mUserTargets = do + globalFlags, _, configExFlags, installFlags, _, _) mUserTargets = do let idxState = flagToMaybe (installIndexState installFlags) @@ -312,7 +317,7 @@ makeInstallPlan verbosity (_, _, comp, platform, _, _, mSandboxPkgInfo, _, configFlags, configExFlags, installFlags, - _) + _, _) (installedPkgIndex, sourcePkgDb, pkgConfigDb, _, pkgSpecifiers, _) = do @@ -328,7 +333,7 @@ -> SolverInstallPlan -> IO () processInstallPlan verbosity - args@(_,_, _, _, _, _, _, _, configFlags, _, installFlags, _) + args@(_,_, _, _, _, _, _, _, configFlags, _, installFlags, _, _) (installedPkgIndex, sourcePkgDb, _, userTargets, pkgSpecifiers, _) installPlan0 = do @@ -384,6 +389,8 @@ . setCountConflicts countConflicts + . setMinimizeConflictSet minimizeConflictSet + . setAvoidReinstalls avoidReinstalls . setShadowPkgs shadowPkgs @@ -392,6 +399,8 @@ . setAllowBootLibInstalls allowBootLibInstalls + . setOnlyConstrained onlyConstrained + . setSolverVerbosity verbosity . setPreferenceDefault (if upgradeDeps then PreferAllLatest @@ -403,7 +412,7 @@ . addPreferences -- preferences from the config file or command line [ PackageVersionPreference name ver - | Dependency name ver <- configPreferences configExFlags ] + | PackageVersionConstraint name ver <- configPreferences configExFlags ] . addConstraints -- version constraints from the config file or command line @@ -448,12 +457,14 @@ fromFlag (installReinstall installFlags) reorderGoals = fromFlag (installReorderGoals installFlags) countConflicts = fromFlag (installCountConflicts installFlags) + minimizeConflictSet = fromFlag (installMinimizeConflictSet installFlags) independentGoals = fromFlag (installIndependentGoals installFlags) avoidReinstalls = fromFlag (installAvoidReinstalls installFlags) shadowPkgs = fromFlag (installShadowPkgs installFlags) strongFlags = fromFlag (installStrongFlags installFlags) maxBackjumps = fromFlag (installMaxBackjumps installFlags) allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags) + onlyConstrained = fromFlag (installOnlyConstrained installFlags) upgradeDeps = fromFlag (installUpgradeDeps installFlags) onlyDeps = fromFlag (installOnlyDeps installFlags) @@ -479,9 +490,9 @@ "Cannot select only the dependencies (as requested by the " ++ "'--only-dependencies' flag), " ++ (case pkgids of - [pkgid] -> "the package " ++ display pkgid ++ " is " + [pkgid] -> "the package " ++ prettyShow pkgid ++ " is " _ -> "the packages " - ++ intercalate ", " (map display pkgids) ++ " are ") + ++ intercalate ", " (map prettyShow pkgids) ++ " are ") ++ "required by a dependency of one of the other targets." where pkgids = @@ -519,7 +530,7 @@ when nothingToInstall $ notice verbosity $ unlines $ "All the requested packages are already installed:" - : map (display . packageId) preExistingTargets + : map (prettyShow . packageId) preExistingTargets ++ ["Use --reinstall if you want to reinstall anyway."] let lPlan = @@ -566,7 +577,7 @@ then do (if dryRun || overrideReinstall then warn else die') verbosity $ unlines $ "The following packages are likely to be broken by the reinstalls:" - : map (display . mungedId) newBrokenPkgs + : map (prettyShow . mungedId) newBrokenPkgs ++ if overrideReinstall then if dryRun then [] else ["Continuing even though " ++ @@ -588,7 +599,7 @@ unless (null notFetched) $ die' verbosity $ "Can't download packages in offline mode. " ++ "Must download the following packages to proceed:\n" - ++ intercalate ", " (map display notFetched) + ++ intercalate ", " (map prettyShow notFetched) ++ "\nTry using 'cabal fetch'." where @@ -662,10 +673,10 @@ wouldWill | dryRun = "would" | otherwise = "will" - showPkg (pkg, _) = display (packageId pkg) ++ + showPkg (pkg, _) = prettyShow (packageId pkg) ++ showLatest (pkg) - showPkgAndReason (ReadyPackage pkg', pr) = display (packageId pkg') ++ + showPkgAndReason (ReadyPackage pkg', pr) = prettyShow (packageId pkg') ++ showLatest pkg' ++ showFlagAssignment (nonDefaultFlags pkg') ++ showStanzas (confPkgStanzas pkg') ++ @@ -682,7 +693,7 @@ showLatest pkg = case mLatestVersion of Just latestVersion -> if packageVersion pkg < latestVersion - then (" (latest: " ++ display latestVersion ++ ")") + then (" (latest: " ++ prettyShow latestVersion ++ ")") else "" Nothing -> "" where @@ -710,19 +721,24 @@ showFlagAssignment :: FlagAssignment -> String showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment - change (OnlyInLeft pkgid) = display pkgid ++ " removed" - change (InBoth pkgid pkgid') = display pkgid ++ " -> " - ++ display (mungedVersion pkgid') - change (OnlyInRight pkgid') = display pkgid' ++ " added" + change (OnlyInLeft pkgid) = prettyShow pkgid ++ " removed" + change (InBoth pkgid pkgid') = prettyShow pkgid ++ " -> " + ++ prettyShow (mungedVersion pkgid') + change (OnlyInRight pkgid') = prettyShow pkgid' ++ " added" showDep pkg | Just rdeps <- Map.lookup (packageId pkg) revDeps - = " (via: " ++ unwords (map display rdeps) ++ ")" + = " (via: " ++ unwords (map prettyShow rdeps) ++ ")" | otherwise = "" revDepGraphEdges :: [(PackageId, PackageId)] revDepGraphEdges = [ (rpid, packageId cpkg) | (ReadyPackage cpkg, _) <- plan - , ConfiguredId rpid (Just PackageDescription.CLibName) _ + , ConfiguredId + rpid + (Just + (PackageDescription.CLibName + PackageDescription.LMainLibName)) + _ <- CD.flatDeps (confPkgDeps cpkg) ] revDeps :: Map.Map PackageId [PackageId] @@ -738,7 +754,7 @@ -> IO () reportPlanningFailure verbosity (_, _, comp, platform, _, _, _ - ,_, configFlags, _, installFlags, _) + ,_, configFlags, _, installFlags, _, _) (_, sourcePkgDb, _, _, pkgSpecifiers, _) message = do @@ -756,7 +772,7 @@ unless (null buildReports) $ info verbosity $ "Solver failure will be reported for " - ++ intercalate "," (map display pkgids) + ++ intercalate "," (map prettyShow pkgids) -- Save reports BuildReports.storeLocal (compilerInfo comp) @@ -818,7 +834,7 @@ -> IO () postInstallActions verbosity (packageDBs, _, comp, platform, progdb, useSandbox, mSandboxPkgInfo - ,globalFlags, configFlags, _, installFlags, _) + ,globalFlags, configFlags, _, installFlags, _, _) targets installPlan buildOutcomes = do updateSandboxTimestampsFile verbosity useSandbox mSandboxPkgInfo @@ -859,7 +875,7 @@ -> [(BuildReports.BuildReport, Maybe Repo)] -> IO () storeDetailedBuildReports verbosity logsDir reports = sequence_ [ do dotCabal <- getCabalDir - let logFileName = display (BuildReports.package report) <.> "log" + let logFileName = prettyShow (BuildReports.package report) <.> "log" logFile = logsDir logFileName reportsDir = dotCabal "reports" remoteRepoName remoteRepo reportFile = reportsDir logFileName @@ -970,14 +986,14 @@ [(_, exe, path)] -> warn verbosity $ "could not create a symlink in " ++ bindir ++ " for " - ++ display exe ++ " because the file exists there already but is not " + ++ prettyShow exe ++ " because the file exists there already but is not " ++ "managed by cabal. You can create a symlink for this executable " ++ "manually if you wish. The executable file has been installed at " ++ path exes -> warn verbosity $ "could not create symlinks in " ++ bindir ++ " for " - ++ intercalate ", " [ display exe | (_, exe, _) <- exes ] + ++ intercalate ", " [ prettyShow exe | (_, exe, _) <- exes ] ++ " because the files exist there already and are not " ++ "managed by cabal. You can create symlinks for these executables " ++ "manually if you wish. The executable files have been installed at " @@ -993,11 +1009,11 @@ [] -> return () failed -> die' verbosity . unlines $ "Error: some packages failed to install:" - : [ display pkgid ++ printFailureReason reason + : [ prettyShow pkgid ++ printFailureReason reason | (pkgid, reason) <- failed ] where printFailureReason reason = case reason of - DependentFailed pkgid -> " depends on " ++ display pkgid + DependentFailed pkgid -> " depends on " ++ prettyShow pkgid ++ " which failed to install." DownloadFailed e -> " failed while downloading the package." ++ showException e @@ -1072,7 +1088,7 @@ -> IO BuildOutcomes performInstallations verbosity (packageDBs, repoCtxt, comp, platform, progdb, useSandbox, _, - globalFlags, configFlags, configExFlags, installFlags, haddockFlags) + globalFlags, configFlags, configExFlags, installFlags, haddockFlags, testFlags) installedPkgIndex installPlan = do -- With 'install -j' it can be a bit hard to tell whether a sandbox is used. @@ -1098,7 +1114,8 @@ (setupScriptOptions installedPkgIndex cacheLock rpkg) configFlags' - installFlags haddockFlags comp progdb + installFlags haddockFlags testFlags + comp progdb platform pkg rpkg pkgoverride mpath useLogFile where @@ -1198,9 +1215,9 @@ -- otherwise. printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO () printBuildResult pkgid uid buildOutcome = case buildOutcome of - (Right _) -> progressMessage verbosity ProgressCompleted (display pkgid) + (Right _) -> progressMessage verbosity ProgressCompleted (prettyShow pkgid) (Left _) -> do - notice verbosity $ "Failed to install " ++ display pkgid + notice verbosity $ "Failed to install " ++ prettyShow pkgid when (verbosity >= normal) $ case useLogFile of Nothing -> return () @@ -1234,16 +1251,21 @@ flags stanzas deps)) installPkg = installPkg configFlags { - configIPID = toFlag (display ipid), + configIPID = toFlag (prettyShow ipid), configConfigurationsFlags = flags, -- We generate the legacy constraints as well as the new style precise deps. -- In the end only one set gets passed to Setup.hs configure, depending on -- the Cabal version we are talking to. configConstraints = [ thisPackageVersion srcid - | ConfiguredId srcid (Just PackageDescription.CLibName) _ipid + | ConfiguredId + srcid + (Just + (PackageDescription.CLibName + PackageDescription.LMainLibName)) + _ipid <- CD.nonSetupDeps deps ], - configDependencies = [ (packageName srcid, dep_ipid) - | ConfiguredId srcid (Just PackageDescription.CLibName) dep_ipid + configDependencies = [ GivenComponent (packageName srcid) cname dep_ipid + | ConfiguredId srcid (Just (PackageDescription.CLibName cname)) dep_ipid <- CD.nonSetupDeps deps ], -- Use '--exact-configuration' if supported. configExactConfiguration = toFlag True, @@ -1311,10 +1333,10 @@ tmp <- getTemporaryDirectory withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath -> onFailure UnpackFailed $ do - let relUnpackedPath = display pkgid + let relUnpackedPath = prettyShow pkgid absUnpackedPath = tmpDirPath relUnpackedPath descFilePath = absUnpackedPath - display (packageName pkgid) <.> "cabal" + prettyShow (packageName pkgid) <.> "cabal" info verbosity $ "Extracting " ++ tarballPath ++ " to " ++ tmpDirPath ++ "..." extractTarGzFile tmpDirPath relUnpackedPath tarballPath @@ -1360,6 +1382,7 @@ -> ConfigFlags -> InstallFlags -> HaddockFlags + -> TestFlags -> Compiler -> ProgramDb -> Platform @@ -1371,16 +1394,16 @@ -> IO BuildOutcome installUnpackedPackage verbosity installLock numJobs scriptOptions - configFlags installFlags haddockFlags comp progdb + configFlags installFlags haddockFlags testFlags comp progdb platform pkg rpkg pkgoverride workingDir useLogFile = do -- Override the .cabal file if necessary case pkgoverride of Nothing -> return () Just pkgtxt -> do let descFilePath = fromMaybe "." workingDir - display (packageName pkgid) <.> "cabal" + prettyShow (packageName pkgid) <.> "cabal" info verbosity $ - "Updating " ++ display (packageName pkgid) <.> "cabal" + "Updating " ++ prettyShow (packageName pkgid) <.> "cabal" ++ " with the latest revision from the index." writeFileAtomic descFilePath pkgtxt @@ -1418,7 +1441,7 @@ -- Tests phase onFailure TestsFailed $ do when (testsEnabled && PackageDescription.hasTests pkg) $ - setup Cabal.testCommand testFlags mLogPath + setup Cabal.testCommand testFlags' mLogPath let testsResult | testsEnabled = TestsOk | otherwise = TestsNotTried @@ -1451,7 +1474,7 @@ uid = installedUnitId rpkg cinfo = compilerInfo comp buildCommand' = buildCommand progdb - dispname = display pkgid + dispname = prettyShow pkgid isParallelBuild = numJobs >= 2 noticeProgress phase = when isParallelBuild $ @@ -1468,7 +1491,7 @@ } testsEnabled = fromFlag (configTests configFlags) && fromFlagOrDefault False (installRunTests installFlags) - testFlags _ = Cabal.emptyTestFlags { + testFlags' = filterTestFlags testFlags { Cabal.testDistPref = configDistPref configFlags } copyFlags _ = Cabal.emptyCopyFlags { @@ -1482,7 +1505,7 @@ Cabal.regVerbosity = toFlag verbosity' } verbosity' = maybe verbosity snd useLogFile - tempTemplate name = name ++ "-" ++ display pkgid + tempTemplate name = name ++ "-" ++ prettyShow pkgid addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags addDefaultInstallDirs configFlags' = do @@ -1526,13 +1549,13 @@ readPkgConf pkgConfDir pkgConfFile = (withUTF8FileContents (pkgConfDir pkgConfFile) $ \pkgConfText -> case Installed.parseInstalledPackageInfo pkgConfText of - Installed.ParseFailed perror -> pkgConfParseFailed perror - Installed.ParseOk warns pkgConf -> do + Left perrors -> pkgConfParseFailed $ unlines perrors + Right (warns, pkgConf) -> do unless (null warns) $ - warn verbosity $ unlines (map (showPWarning pkgConfFile) warns) + warn verbosity $ unlines warns return pkgConf) - pkgConfParseFailed :: Installed.PError -> IO a + pkgConfParseFailed :: String -> IO a pkgConfParseFailed perror = die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':" ++ show perror @@ -1603,7 +1626,7 @@ [ InstallDirs.bindir absoluteDirs exeName <.> exeExtension buildPlatform | exe <- PackageDescription.executables pkg , PackageDescription.buildable (PackageDescription.buildInfo exe) - , let exeName = prefix ++ display (PackageDescription.exeName exe) ++ suffix + , let exeName = prefix ++ prettyShow (PackageDescription.exeName exe) ++ suffix prefix = substTemplate prefixTemplate suffix = substTemplate suffixTemplate ] where diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs --- a/Distribution/Client/InstallPlan.hs +++ b/Distribution/Client/InstallPlan.hs @@ -79,7 +79,7 @@ , HasUnitId(..), UnitId ) import Distribution.Solver.Types.SolverPackage import Distribution.Client.JobControl -import Distribution.Text +import Distribution.Deprecated.Text import Text.PrettyPrint import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.SolverInstallPlan (SolverInstallPlan) @@ -527,7 +527,7 @@ Cabal.NoFlag Cabal.NoFlag (packageId spkg) - PD.CLibName + (PD.CLibName PD.LMainLibName) (Just (map confInstId (CD.libraryDeps deps), solverPkgFlags spkg)), confPkgSource = solverPkgSource spkg, diff --git a/Distribution/Client/InstallSymlink.hs b/Distribution/Client/InstallSymlink.hs --- a/Distribution/Client/InstallSymlink.hs +++ b/Distribution/Client/InstallSymlink.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.InstallSymlink @@ -19,6 +20,9 @@ #ifdef mingw32_HOST_OS +import Distribution.Compat.Binary + ( Binary ) + import Distribution.Package (PackageIdentifier) import Distribution.Types.UnqualComponentName import Distribution.Client.InstallPlan (InstallPlan) @@ -27,10 +31,13 @@ import Distribution.Simple.Setup (ConfigFlags) import Distribution.Simple.Compiler import Distribution.System +import GHC.Generics (Generic) data OverwritePolicy = NeverOverwrite | AlwaysOverwrite - deriving (Show, Eq) + deriving (Show, Eq, Generic, Bounded, Enum) +instance Binary OverwritePolicy + symlinkBinaries :: Platform -> Compiler -> OverwritePolicy -> ConfigFlags @@ -47,6 +54,9 @@ #else +import Distribution.Compat.Binary + ( Binary ) + import Distribution.Client.Types ( ConfiguredPackage(..), BuildOutcomes ) import Distribution.Client.Setup @@ -74,7 +84,7 @@ ( Compiler, compilerInfo, CompilerInfo(..) ) import Distribution.System ( Platform ) -import Distribution.Text +import Distribution.Deprecated.Text ( display ) import System.Posix.Files @@ -93,9 +103,13 @@ ( assert ) import Data.Maybe ( catMaybes ) +import GHC.Generics + ( Generic ) data OverwritePolicy = NeverOverwrite | AlwaysOverwrite - deriving (Show, Eq) + deriving (Show, Eq, Generic, Bounded, Enum) + +instance Binary OverwritePolicy -- | We would like by default to install binaries into some location that is on -- the user's PATH. For per-user installations on Unix systems that basically diff --git a/Distribution/Client/List.hs b/Distribution/Client/List.hs --- a/Distribution/Client/List.hs +++ b/Distribution/Client/List.hs @@ -40,7 +40,7 @@ ( Version, mkVersion, versionNumbers, VersionRange, withinRange, anyVersion , intersectVersionRanges, simplifyVersionRange ) import Distribution.Verbosity (Verbosity) -import Distribution.Text +import Distribution.Deprecated.Text ( Text(disp), display ) import qualified Distribution.SPDX as SPDX @@ -231,9 +231,9 @@ selectedInstalledPkgs = InstalledPackageIndex.lookupDependency installedPkgIndex - (Dependency name verConstraint) + name verConstraint selectedSourcePkgs = PackageIndex.lookupDependency sourcePkgIndex - (Dependency name verConstraint) + name verConstraint selectedSourcePkg' = latestWithPref pref selectedSourcePkgs -- display a specific package version if the user diff --git a/Distribution/Client/Outdated.hs b/Distribution/Client/Outdated.hs --- a/Distribution/Client/Outdated.hs +++ b/Distribution/Client/Outdated.hs @@ -36,14 +36,14 @@ import Distribution.Simple.Utils (die', notice, debug, tryFindPackageDesc) import Distribution.System (Platform) -import Distribution.Text (display) +import Distribution.Deprecated.Text (display) import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec(..)) import Distribution.Types.Dependency (Dependency(..), depPkgName, simplifyDependency) import Distribution.Verbosity (Verbosity, silent) import Distribution.Version - (Version, LowerBound(..), UpperBound(..) + (Version, VersionRange, LowerBound(..), UpperBound(..) ,asVersionIntervals, majorBoundVersion) import Distribution.PackageDescription.Parsec (readGenericPackageDescription) @@ -80,7 +80,7 @@ when (not newFreezeFile && isJust mprojectFile) $ die' verbosity $ - "--project-file must only be used with --new-freeze-file." + "--project-file must only be used with --v2-freeze-file." sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext let pkgIndex = packageIndex sourcePkgDb @@ -107,7 +107,7 @@ then do when (not simpleOutput) $ notice verbosity "Outdated dependencies:" - for_ outdatedDeps $ \(d@(Dependency pn _), v) -> + for_ outdatedDeps $ \(d@(Dependency pn _ _), v) -> let outdatedDep = if simpleOutput then display pn else display d ++ " (latest: " ++ display v ++ ")" in notice verbosity outdatedDep @@ -149,7 +149,7 @@ depsFromPkgDesc :: Verbosity -> Compiler -> Platform -> IO [Dependency] depsFromPkgDesc verbosity comp platform = do cwd <- getCurrentDirectory - path <- tryFindPackageDesc cwd + path <- tryFindPackageDesc verbosity cwd gpd <- readGenericPackageDescription verbosity path let cinfo = compilerInfo comp epd = finalizePD mempty (ComponentRequestedSpec True True) @@ -179,10 +179,10 @@ mapMaybe isOutdated $ map simplifyDependency deps where isOutdated :: Dependency -> Maybe (Dependency, Version) - isOutdated dep + isOutdated dep@(Dependency pname vr _) | ignorePred (depPkgName dep) = Nothing | otherwise = - let this = map packageVersion $ lookupDependency pkgIndex dep + let this = map packageVersion $ lookupDependency pkgIndex pname vr latest = lookupLatest dep in (\v -> (dep, v)) `fmap` isOutdated' this latest @@ -195,17 +195,16 @@ in if this' < latest' then Just latest' else Nothing lookupLatest :: Dependency -> [Version] - lookupLatest dep + lookupLatest dep@(Dependency pname vr _) | minorPred (depPkgName dep) = - map packageVersion $ lookupDependency pkgIndex (relaxMinor dep) + map packageVersion $ lookupDependency pkgIndex pname (relaxMinor vr) | otherwise = map packageVersion $ lookupPackageName pkgIndex (depPkgName dep) - relaxMinor :: Dependency -> Dependency - relaxMinor (Dependency pn vr) = (Dependency pn vr') - where - vr' = let vis = asVersionIntervals vr - (LowerBound v0 _,upper) = last vis - in case upper of - NoUpperBound -> vr - UpperBound _v1 _ -> majorBoundVersion v0 + relaxMinor :: VersionRange -> VersionRange + relaxMinor vr = + let vis = asVersionIntervals vr + (LowerBound v0 _,upper) = last vis + in case upper of + NoUpperBound -> vr + UpperBound _v1 _ -> majorBoundVersion v0 diff --git a/Distribution/Client/PackageHash.hs b/Distribution/Client/PackageHash.hs --- a/Distribution/Client/PackageHash.hs +++ b/Distribution/Client/PackageHash.hs @@ -44,9 +44,10 @@ , ProfDetailLevel(..), showProfDetailLevel ) import Distribution.Simple.InstallDirs ( PathTemplate, fromPathTemplate ) -import Distribution.Text +import Distribution.Pretty (prettyShow) +import Distribution.Deprecated.Text ( display ) -import Distribution.Version +import Distribution.Types.PkgconfigVersion (PkgconfigVersion) import Distribution.Client.Types ( InstalledPackageId ) import qualified Distribution.Solver.Types.ComponentDeps as CD @@ -176,7 +177,7 @@ pkgHashPkgId :: PackageId, pkgHashComponent :: Maybe CD.Component, pkgHashSourceHash :: PackageSourceHash, - pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe Version), + pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion), pkgHashDirectDeps :: Set InstalledPackageId, pkgHashOtherConfig :: PackageHashConfigInputs } @@ -194,6 +195,7 @@ pkgHashVanillaLib :: Bool, pkgHashSharedLib :: Bool, pkgHashDynExe :: Bool, + pkgHashFullyStaticExe :: Bool, pkgHashGHCiLib :: Bool, pkgHashProfLib :: Bool, pkgHashProfExe :: Bool, @@ -275,7 +277,7 @@ (intercalate ", " . map (\(pn, mb_v) -> display pn ++ case mb_v of Nothing -> "" - Just v -> " " ++ display v) + Just v -> " " ++ prettyShow v) . Set.toList) pkgHashPkgConfigDeps , entry "deps" (intercalate ", " . map display . Set.toList) pkgHashDirectDeps @@ -287,6 +289,7 @@ , opt "vanilla-lib" True display pkgHashVanillaLib , opt "shared-lib" False display pkgHashSharedLib , opt "dynamic-exe" False display pkgHashDynExe + , opt "fully-static-exe" False display pkgHashFullyStaticExe , opt "ghci-lib" False display pkgHashGHCiLib , opt "prof-lib" False display pkgHashProfLib , opt "prof-exe" False display pkgHashProfExe diff --git a/Distribution/Client/PackageUtils.hs b/Distribution/Client/PackageUtils.hs --- a/Distribution/Client/PackageUtils.hs +++ b/Distribution/Client/PackageUtils.hs @@ -14,16 +14,14 @@ externalBuildDepends, ) where -import Distribution.Package - ( packageVersion, packageName ) -import Distribution.Types.ComponentRequestedSpec - ( ComponentRequestedSpec ) +import Distribution.Package (packageName, packageVersion) +import Distribution.PackageDescription + (PackageDescription (..), enabledBuildDepends, libName) +import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec) import Distribution.Types.Dependency +import Distribution.Types.LibraryName import Distribution.Types.UnqualComponentName -import Distribution.PackageDescription - ( PackageDescription(..), libName, enabledBuildDepends ) -import Distribution.Version - ( withinRange, isAnyVersion ) +import Distribution.Version (isAnyVersion, withinRange) -- | The list of dependencies that refer to external packages -- rather than internal package components. @@ -33,8 +31,8 @@ where -- True if this dependency is an internal one (depends on a library -- defined in the same package). - internal (Dependency depName versionRange) = + internal (Dependency depName versionRange _) = (depName == packageName pkg && packageVersion pkg `withinRange` versionRange) || - (Just (packageNameToUnqualComponentName depName) `elem` map libName (subLibraries pkg) && + (LSubLibName (packageNameToUnqualComponentName depName) `elem` map libName (subLibraries pkg) && isAnyVersion versionRange) diff --git a/Distribution/Client/ParseUtils.hs b/Distribution/Client/ParseUtils.hs --- a/Distribution/Client/ParseUtils.hs +++ b/Distribution/Client/ParseUtils.hs @@ -39,11 +39,14 @@ ) where -import Distribution.ParseUtils +import Distribution.Deprecated.ParseUtils ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo , Field(..), liftField, readFieldsFlat ) +import Distribution.Deprecated.ViewAsFieldDescr + ( viewAsFieldDescr ) + import Distribution.Simple.Command - ( OptionField, viewAsFieldDescr ) + ( OptionField ) import Control.Monad ( foldM ) import Text.PrettyPrint ( (<+>), ($+$) ) @@ -150,7 +153,7 @@ warning $ "Unrecognized stanza on line " ++ show (lineNo f) return accum --- | This is a customised version of the functions from Distribution.ParseUtils +-- | This is a customised version of the functions from Distribution.Deprecated.ParseUtils -- that also optionally print default values for empty fields as comments. -- ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc diff --git a/Distribution/Client/ProjectBuilding.hs b/Distribution/Client/ProjectBuilding.hs --- a/Distribution/Client/ProjectBuilding.hs +++ b/Distribution/Client/ProjectBuilding.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NamedFieldPuns, - ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoMonoLocalBinds #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -- | -- @@ -62,14 +65,14 @@ import qualified Distribution.Client.Tar as Tar import Distribution.Client.Setup ( filterConfigureFlags, filterHaddockArgs - , filterHaddockFlags ) + , filterHaddockFlags, filterTestFlags ) import Distribution.Client.SourceFiles import Distribution.Client.SrcDist (allPackageSourceFiles) import Distribution.Client.Utils ( ProgressPhase(..), progressMessage, removeExistingFile ) import Distribution.Compat.Lens -import Distribution.Package hiding (InstalledPackageId, installedPackageId) +import Distribution.Package import qualified Distribution.PackageDescription as PD import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as Installed @@ -81,15 +84,15 @@ import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Command (CommandUI) import qualified Distribution.Simple.Register as Cabal -import Distribution.Simple.LocalBuildInfo (ComponentName(..)) +import Distribution.Simple.LocalBuildInfo + ( ComponentName(..), LibraryName(..) ) import Distribution.Simple.Compiler ( Compiler, compilerId, PackageDB(..) ) import Distribution.Simple.Utils import Distribution.Version import Distribution.Verbosity -import Distribution.Text -import Distribution.ParseUtils ( showPWarning ) +import Distribution.Pretty import Distribution.Compat.Graph (IsNode(..)) import Data.Map (Map) @@ -233,7 +236,8 @@ case elabBuildStyle pkg of BuildAndInstall -> return (BuildStatusUnpack tarball) BuildInplaceOnly -> do - -- TODO: [nice to have] use a proper file monitor rather than this dir exists test + -- TODO: [nice to have] use a proper file monitor rather + -- than this dir exists test exists <- doesDirectoryExist srcdir if exists then dryRunLocalPkg pkg depsBuildStatus srcdir @@ -260,7 +264,8 @@ return (BuildStatusUpToDate buildResult) where packageFileMonitor = - newPackageFileMonitor shared distDirLayout (elabDistDirParams shared pkg) + newPackageFileMonitor shared distDirLayout + (elabDistDirParams shared pkg) -- | A specialised traversal over the packages in an install plan. @@ -308,7 +313,7 @@ Just BuildStatusUpToDate {} -> True Just _ -> False Nothing -> error $ "improveInstallPlanWithUpToDatePackages: " - ++ display (packageId pkg) ++ " not in status map" + ++ prettyShow (packageId pkg) ++ " not in status map" ----------------------------- @@ -410,7 +415,8 @@ -> IO (Either BuildStatusRebuild BuildResult) checkPackageFileMonitorChanged PackageFileMonitor{..} pkg srcdir depsBuildStatus = do - --TODO: [nice to have] some debug-level message about file changes, like rerunIfChanged + --TODO: [nice to have] some debug-level message about file + --changes, like rerunIfChanged configChanged <- checkFileMonitorChanged pkgFileMonitorConfig srcdir pkgconfig case configChanged of @@ -685,7 +691,8 @@ unpackTarballPhase tarball = withTarballLocalDirectory verbosity distDirLayout tarball - (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) (elabBuildStyle pkg) + (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) + (elabBuildStyle pkg) (elabPkgDescriptionOverride pkg) $ case elabBuildStyle pkg of @@ -703,7 +710,8 @@ buildInplace buildStatus srcdir builddir where - builddir = distBuildDirectory (elabDistDirParams sharedPackageConfig pkg) + builddir = distBuildDirectory + (elabDistDirParams sharedPackageConfig pkg) buildAndInstall srcdir builddir = buildAndInstallUnpackedPackage @@ -822,7 +830,7 @@ withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do unpackPackageTarball verbosity tarball unpackdir pkgid pkgTextOverride - let srcdir = unpackdir display pkgid + let srcdir = unpackdir prettyShow pkgid builddir = srcdir "dist" buildPkg srcdir builddir @@ -833,7 +841,8 @@ let srcrootdir = distUnpackedSrcRootDirectory srcdir = distUnpackedSrcDirectory pkgid builddir = distBuildDirectory dparams - -- TODO: [nice to have] use a proper file monitor rather than this dir exists test + -- TODO: [nice to have] use a proper file monitor rather + -- than this dir exists test exists <- doesDirectoryExist srcdir unless exists $ do createDirectoryIfMissingVerbose verbosity True srcrootdir @@ -860,21 +869,22 @@ -- exists <- doesFileExist cabalFile unless exists $ - die' verbosity $ "Package .cabal file not found in the tarball: " ++ cabalFile + die' verbosity $ + "Package .cabal file not found in the tarball: " ++ cabalFile -- Overwrite the .cabal with the one from the index, when appropriate -- case pkgTextOverride of Nothing -> return () Just pkgtxt -> do - info verbosity $ "Updating " ++ display pkgname <.> "cabal" + info verbosity $ "Updating " ++ prettyShow pkgname <.> "cabal" ++ " with the latest revision from the index." writeFileAtomic cabalFile pkgtxt where cabalFile = parentdir pkgsubdir - display pkgname <.> "cabal" - pkgsubdir = display pkgid + prettyShow pkgname <.> "cabal" + pkgsubdir = prettyShow pkgid pkgname = packageName pkgid @@ -886,7 +896,8 @@ -- system, though we'll still need to keep this hack for older packages. -- moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout - -> FilePath -> PackageId -> DistDirParams -> IO () + -> FilePath -> PackageId -> DistDirParams + -> IO () moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory} parentdir pkgid dparams = do distDirExists <- doesDirectoryExist tarballDistDir @@ -896,7 +907,7 @@ --TODO: [nice to have] or perhaps better to copy, and use a file monitor renameDirectory tarballDistDir targetDistDir where - tarballDistDir = parentdir display pkgid "dist" + tarballDistDir = parentdir prettyShow pkgid "dist" targetDistDir = distBuildDirectory dparams @@ -927,15 +938,16 @@ plan rpkg@(ReadyPackage pkg) srcdir builddir = do - createDirectoryIfMissingVerbose verbosity True builddir + createDirectoryIfMissingVerbose verbosity True (srcdir builddir) initLogFile - --TODO: [code cleanup] deal consistently with talking to older Setup.hs versions, much like - -- we do for ghc, with a proper options type and rendering step - -- which will also let us call directly into the lib, rather than always - -- going via the lib's command line interface, which would also allow - -- passing data like installed packages, compiler, and program db for a - -- quicker configure. + --TODO: [code cleanup] deal consistently with talking to older + -- Setup.hs versions, much like we do for ghc, with a proper + -- options type and rendering step which will also let us + -- call directly into the lib, rather than always going via + -- the lib's command line interface, which would also allow + -- passing data like installed packages, compiler, and + -- program db for a quicker configure. --TODO: [required feature] docs and tests --TODO: [required feature] sudo re-exec @@ -968,21 +980,28 @@ -- Note that the copy command has put the files into -- @$tmpDir/$prefix@ so we need to return this dir so -- the store knows which dir will be the final store entry. - let prefix = normalise $ dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) + let prefix = normalise $ + dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) entryDir = tmpDirNormalised prefix LBS.writeFile (entryDir "cabal-hash.txt") (renderPackageHashInputs (packageHashInputs pkgshared pkg)) - -- Ensure that there are no files in `tmpDir`, that are not in `entryDir` - -- While this breaks the prefix-relocatable property of the lirbaries - -- it is necessary on macOS to stay under the load command limit of the - -- macOS mach-o linker. See also @PackageHash.hashedInstalledPackageIdVeryShort@. - -- We also normalise paths to ensure that there are no different representations - -- for the same path. Like / and \\ on windows under msys. - otherFiles <- filter (not . isPrefixOf entryDir) <$> listFilesRecursive tmpDirNormalised - -- here's where we could keep track of the installed files ourselves - -- if we wanted to by making a manifest of the files in the tmp dir + -- Ensure that there are no files in `tmpDir`, that are + -- not in `entryDir`. While this breaks the + -- prefix-relocatable property of the libraries, it is + -- necessary on macOS to stay under the load command limit + -- of the macOS mach-o linker. See also + -- @PackageHash.hashedInstalledPackageIdVeryShort@. + -- + -- We also normalise paths to ensure that there are no + -- different representations for the same path. Like / and + -- \\ on windows under msys. + otherFiles <- filter (not . isPrefixOf entryDir) <$> + listFilesRecursive tmpDirNormalised + -- Here's where we could keep track of the installed files + -- ourselves if we wanted to by making a manifest of the + -- files in the tmp dir. return (entryDir, otherFiles) where listFilesRecursive :: FilePath -> IO [FilePath] @@ -998,7 +1017,8 @@ registerPkg | not (elabRequiresRegistration pkg) = debug verbosity $ - "registerPkg: elab does NOT require registration for " ++ display uid + "registerPkg: elab does NOT require registration for " + ++ prettyShow uid | otherwise = do -- We register ourselves rather than via Setup.hs. We need to -- grab and modify the InstalledPackageInfo. We decide what @@ -1027,8 +1047,9 @@ -- final location ourselves, perhaps we ought to do some sanity checks on -- the image dir first. - -- TODO: [required eventually] note that for nix-style installations it is not necessary to do - -- the 'withWin32SelfUpgrade' dance, but it would be necessary for a + -- TODO: [required eventually] note that for nix-style + -- installations it is not necessary to do the + -- 'withWin32SelfUpgrade' dance, but it would be necessary for a -- shared bin dir. --TODO: [required feature] docs and test phases @@ -1049,10 +1070,10 @@ compid = compilerId compiler dispname = case elabPkgOrComp pkg of - ElabPackage _ -> display pkgid + ElabPackage _ -> prettyShow pkgid ++ " (all, legacy fallback)" - ElabComponent comp -> display pkgid - ++ " (" ++ maybe "custom" display (compComponentName comp) ++ ")" + ElabComponent comp -> prettyShow pkgid + ++ " (" ++ maybe "custom" prettyShow (compComponentName comp) ++ ")" noticeProgress phase = when isParallelBuild $ progressMessage verbosity phase dispname @@ -1096,14 +1117,16 @@ setup :: CommandUI flags -> (Version -> flags) -> IO () setup cmd flags = setup' cmd flags (const []) - setup' :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) -> IO () + setup' :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) + -> IO () setup' cmd flags args = withLogging $ \mLogFileHandle -> setupWrapper verbosity scriptOptions { useLoggingHandle = mLogFileHandle - , useExtraEnvOverrides = dataDirsEnvironmentForPlan distDirLayout plan } + , useExtraEnvOverrides = dataDirsEnvironmentForPlan + distDirLayout plan } (Just (elabPkgDescription pkg)) cmd flags args @@ -1138,12 +1161,12 @@ componentHasHaddocks :: ComponentTarget -> Bool componentHasHaddocks (ComponentTarget name _) = case name of - CLibName -> hasHaddocks - CSubLibName _ -> elabHaddockInternal && hasHaddocks - CFLibName _ -> elabHaddockForeignLibs && hasHaddocks - CExeName _ -> elabHaddockExecutables && hasHaddocks - CTestName _ -> elabHaddockTestSuites && hasHaddocks - CBenchName _ -> elabHaddockBenchmarks && hasHaddocks + CLibName LMainLibName -> hasHaddocks + CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks + CFLibName _ -> elabHaddockForeignLibs && hasHaddocks + CExeName _ -> elabHaddockExecutables && hasHaddocks + CTestName _ -> elabHaddockTestSuites && hasHaddocks + CBenchName _ -> elabHaddockBenchmarks && hasHaddocks where hasHaddocks = not (null (elabPkgDescription ^. componentModules name)) @@ -1174,10 +1197,12 @@ buildStatus srcdir builddir = do - --TODO: [code cleanup] there is duplication between the distdirlayout and the builddir here - -- builddir is not enough, we also need the per-package cachedir + --TODO: [code cleanup] there is duplication between the + -- distdirlayout and the builddir here builddir is not + -- enough, we also need the per-package cachedir createDirectoryIfMissingVerbose verbosity True builddir - createDirectoryIfMissingVerbose verbosity True (distPackageCacheDirectory dparams) + createDirectoryIfMissingVerbose verbosity True + (distPackageCacheDirectory dparams) -- Configure phase -- @@ -1276,7 +1301,8 @@ when (haddockTarget == Cabal.ForHackage) $ do let dest = distDirectory name <.> "tar.gz" name = haddockDirName haddockTarget (elabPkgDescription pkg) - docDir = distBuildDirectory distDirLayout dparams "doc" "html" + docDir = distBuildDirectory distDirLayout dparams + "doc" "html" Tar.createTarGzFile dest docDir name notice verbosity $ "Documentation tarball created: " ++ dest @@ -1324,9 +1350,11 @@ whenReRegister action = case buildStatus of -- We registered the package already - BuildStatusBuild (Just _) _ -> info verbosity "whenReRegister: previously registered" + BuildStatusBuild (Just _) _ -> + info verbosity "whenReRegister: previously registered" -- There is nothing to register - _ | null (elabBuildTargets pkg) -> info verbosity "whenReRegister: nothing to register" + _ | null (elabBuildTargets pkg) -> + info verbosity "whenReRegister: nothing to register" | otherwise -> action configureCommand = Cabal.configureCommand defaultProgramDb @@ -1341,7 +1369,8 @@ buildArgs _ = setupHsBuildArgs pkg testCommand = Cabal.testCommand -- defaultProgramDb - testFlags _ = setupHsTestFlags pkg pkgshared + testFlags v = flip filterTestFlags v $ + setupHsTestFlags pkg pkgshared verbosity builddir testArgs _ = setupHsTestArgs pkg @@ -1374,7 +1403,8 @@ (Just (elabPkgDescription pkg)) cmd flags args - setup :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) -> IO () + setup :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) + -> IO () setup cmd flags args = setupWrapper verbosity scriptOptions @@ -1404,19 +1434,21 @@ readPkgConf "." pkgConfDest where - pkgConfParseFailed :: Installed.PError -> IO a + pkgConfParseFailed :: String -> IO a pkgConfParseFailed perror = - die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':" - ++ show perror + die' verbosity $ + "Couldn't parse the output of 'setup register --gen-pkg-config':" + ++ show perror readPkgConf pkgConfDir pkgConfFile = do - (warns, ipkg) <- withUTF8FileContents (pkgConfDir pkgConfFile) $ \pkgConfStr -> + (warns, ipkg) <- + withUTF8FileContents (pkgConfDir pkgConfFile) $ \pkgConfStr -> case Installed.parseInstalledPackageInfo pkgConfStr of - Installed.ParseFailed perror -> pkgConfParseFailed perror - Installed.ParseOk warns ipkg -> return (warns, ipkg) + Left perrors -> pkgConfParseFailed $ unlines perrors + Right (warns, ipkg) -> return (warns, ipkg) unless (null warns) $ - warn verbosity $ unlines (map (showPWarning pkgConfFile) warns) + warn verbosity $ unlines warns return ipkg diff --git a/Distribution/Client/ProjectConfig.hs b/Distribution/Client/ProjectConfig.hs --- a/Distribution/Client/ProjectConfig.hs +++ b/Distribution/Client/ProjectConfig.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, DeriveDataTypeable, LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} -- | Handling project configuration. -- @@ -74,6 +79,7 @@ import Distribution.Client.HttpUtils ( HttpTransport, configureTransport, transportCheckHttps , downloadURI ) +import Distribution.Client.Utils.Parsec (renderParseError) import Distribution.Solver.Types.SourcePackage import Distribution.Solver.Types.Settings @@ -82,17 +88,17 @@ import Distribution.Package ( PackageName, PackageId, packageId, UnitId ) -import Distribution.Types.Dependency +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint(..) ) import Distribution.System ( Platform ) import Distribution.Types.GenericPackageDescription ( GenericPackageDescription ) import Distribution.PackageDescription.Parsec ( parseGenericPackageDescription ) -import Distribution.Parsec.ParseResult - ( runParseResult ) -import Distribution.Parsec.Common as NewParser - ( PError, PWarning, showPWarning ) +import Distribution.Fields + ( runParseResult, PError, PWarning, showPWarning) +import Distribution.Pretty () import Distribution.Types.SourceRepo ( SourceRepo(..), RepoType(..), ) import Distribution.Simple.Compiler @@ -117,8 +123,8 @@ ( Verbosity, modifyVerbosity, verbose ) import Distribution.Version ( Version ) -import Distribution.Text -import Distribution.ParseUtils as OldParser +import Distribution.Deprecated.Text +import qualified Distribution.Deprecated.ParseUtils as OldParser ( ParseResult(..), locatedErrorMsg, showPWarning ) import qualified Codec.Archive.Tar as Tar @@ -130,8 +136,8 @@ import Control.Monad.Trans (liftIO) import Control.Exception import Data.Either -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set @@ -154,10 +160,10 @@ -- 'PackageName'. This returns the configuration that applies to all local -- packages plus any package-specific configuration for this package. -- -lookupLocalPackageConfig :: (Semigroup a, Monoid a) - => (PackageConfig -> a) - -> ProjectConfig - -> PackageName -> a +lookupLocalPackageConfig + :: (Semigroup a, Monoid a) + => (PackageConfig -> a) -> ProjectConfig -> PackageName + -> a lookupLocalPackageConfig field ProjectConfig { projectConfigLocalPackages, projectConfigSpecificPackage @@ -188,10 +194,10 @@ -- that doesn't have an http transport. And that avoids having to have access -- to the 'BuildTimeSettings' -- -projectConfigWithSolverRepoContext :: Verbosity - -> ProjectConfigShared - -> ProjectConfigBuildOnly - -> (RepoContext -> IO a) -> IO a +projectConfigWithSolverRepoContext + :: Verbosity -> ProjectConfigShared -> ProjectConfigBuildOnly + -> (RepoContext -> IO a) + -> IO a projectConfigWithSolverRepoContext verbosity ProjectConfigShared{..} ProjectConfigBuildOnly{..} = @@ -199,8 +205,10 @@ verbosity (fromNubList projectConfigRemoteRepos) (fromNubList projectConfigLocalRepos) - (fromFlagOrDefault (error "projectConfigWithSolverRepoContext: projectConfigCacheDir") - projectConfigCacheDir) + (fromFlagOrDefault + (error + "projectConfigWithSolverRepoContext: projectConfigCacheDir") + projectConfigCacheDir) (flagToMaybe projectConfigHttpTransport) (flagToMaybe projectConfigIgnoreExpiry) (fromNubList projectConfigProgPathExtra) @@ -235,8 +243,10 @@ | otherwise -> Just n solverSettingReorderGoals = fromFlag projectConfigReorderGoals solverSettingCountConflicts = fromFlag projectConfigCountConflicts + solverSettingMinimizeConflictSet = fromFlag projectConfigMinimizeConflictSet solverSettingStrongFlags = fromFlag projectConfigStrongFlags solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls + solverSettingOnlyConstrained = fromFlag projectConfigOnlyConstrained solverSettingIndexState = flagToMaybe projectConfigIndexState solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals --solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs @@ -254,8 +264,10 @@ projectConfigMaxBackjumps = Flag defaultMaxBackjumps, projectConfigReorderGoals = Flag (ReorderGoals False), projectConfigCountConflicts = Flag (CountConflicts True), + projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False), projectConfigStrongFlags = Flag (StrongFlags False), projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False), + projectConfigOnlyConstrained = Flag OnlyConstrainedNone, projectConfigIndependentGoals = Flag (IndependentGoals False) --projectConfigShadowPkgs = Flag False, --projectConfigReinstall = Flag False, @@ -439,7 +451,7 @@ renderBadProjectRoot (BadProjectRootExplicitFile projectFile) = "The given project file '" ++ projectFile ++ "' does not exist." -withProjectOrGlobalConfig :: Verbosity +withProjectOrGlobalConfig :: Verbosity -> Flag FilePath -> IO a -> (ProjectConfig -> IO a) @@ -450,9 +462,9 @@ let res' = catch with $ \case - (BadPackageLocations prov locs) + (BadPackageLocations prov locs) | prov == Set.singleton Implicit - , let + , let isGlobErr (BadLocGlobEmptyMatch _) = True isGlobErr _ = False , any isGlobErr locs -> @@ -564,7 +576,7 @@ -- For the moment this is implemented in terms of parsers for legacy -- configuration types, plus a conversion. -- -parseProjectConfig :: String -> ParseResult ProjectConfig +parseProjectConfig :: String -> OldParser.ParseResult ProjectConfig parseProjectConfig content = convertLegacyProjectConfig <$> parseLegacyProjectConfig content @@ -610,14 +622,14 @@ monitorFiles [monitorFileHashed configFile] return (convertLegacyGlobalConfig config) -reportParseResult :: Verbosity -> String -> FilePath -> ParseResult a -> IO a -reportParseResult verbosity _filetype filename (ParseOk warnings x) = do +reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult a -> IO a +reportParseResult verbosity _filetype filename (OldParser.ParseOk warnings x) = do unless (null warnings) $ let msg = unlines (map (OldParser.showPWarning filename) warnings) in warn verbosity msg return x -reportParseResult verbosity filetype filename (ParseFailed err) = - let (line, msg) = locatedErrorMsg err +reportParseResult verbosity filetype filename (OldParser.ParseFailed err) = + let (line, msg) = OldParser.locatedErrorMsg err in die' verbosity $ "Error parsing " ++ filetype ++ " " ++ filename ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg @@ -636,7 +648,7 @@ | ProjectPackageLocalTarball FilePath | ProjectPackageRemoteTarball URI | ProjectPackageRemoteRepo SourceRepo - | ProjectPackageNamed Dependency + | ProjectPackageNamed PackageVersionConstraint deriving Show @@ -990,7 +1002,7 @@ let pkgsNamed = [ NamedPackage pkgname [PackagePropertyVersion verrange] - | ProjectPackageNamed (Dependency pkgname verrange) <- pkgLocations ] + | ProjectPackageNamed (PackageVersionConstraint pkgname verrange) <- pkgLocations ] return $ concat [ pkgsLocalDirectory @@ -1216,16 +1228,33 @@ -- | Errors reported upon failing to parse a @.cabal@ file. -- -data CabalFileParseError = - CabalFileParseError - FilePath - [PError] - (Maybe Version) -- We might discover the spec version the package needs - [PWarning] - deriving (Show, Typeable) +data CabalFileParseError = CabalFileParseError + FilePath -- ^ @.cabal@ file path + BS.ByteString -- ^ @.cabal@ file contents + [PError] -- ^ errors + (Maybe Version) -- ^ We might discover the spec version the package needs + [PWarning] -- ^ warnings + deriving (Typeable) +-- | Manual instance which skips file contentes +instance Show CabalFileParseError where + showsPrec d (CabalFileParseError fp _ es mv ws) = showParen (d > 10) + $ showString "CabalFileParseError" + . showChar ' ' . showsPrec 11 fp + . showChar ' ' . showsPrec 11 ("" :: String) + . showChar ' ' . showsPrec 11 es + . showChar ' ' . showsPrec 11 mv + . showChar ' ' . showsPrec 11 ws + instance Exception CabalFileParseError +#if MIN_VERSION_base(4,8,0) + where + displayException = renderCabalFileParseError +#endif +renderCabalFileParseError :: CabalFileParseError -> String +renderCabalFileParseError (CabalFileParseError filePath contents errors _ warnings) = + renderParseError filePath contents errors warnings -- | Wrapper for the @.cabal@ file parser. It reports warnings on higher -- verbosity levels and throws 'CabalFileParseError' on failure. @@ -1242,12 +1271,12 @@ return pkg (warnings, Left (mspecVersion, errors)) -> - throwIO $ CabalFileParseError pkgfilename errors mspecVersion warnings + throwIO $ CabalFileParseError pkgfilename content errors mspecVersion warnings where formatWarnings warnings = "The package description file " ++ pkgfilename ++ " has warnings: " - ++ unlines (map (NewParser.showPWarning pkgfilename) warnings) + ++ unlines (map (showPWarning pkgfilename) warnings) -- | When looking for a package's @.cabal@ file we can find none, or several, diff --git a/Distribution/Client/ProjectConfig/Legacy.hs b/Distribution/Client/ProjectConfig/Legacy.hs --- a/Distribution/Client/ProjectConfig/Legacy.hs +++ b/Distribution/Client/ProjectConfig/Legacy.hs @@ -23,6 +23,8 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Deprecated.ParseUtils (parseFlagAssignment) + import Distribution.Client.ProjectConfig.Types import Distribution.Client.Types ( RemoteRepo(..), emptyRemoteRepo @@ -31,12 +33,16 @@ import Distribution.Client.Config ( SavedConfig(..), remoteRepoFields ) +import Distribution.Client.CmdInstall.ClientInstallFlags + ( ClientInstallFlags(..), defaultClientInstallFlags + , clientInstallOptions ) + import Distribution.Solver.Types.ConstraintSource import Distribution.Package import Distribution.PackageDescription ( SourceRepo(..), RepoKind(..) - , dispFlagAssignment, parseFlagAssignment ) + , dispFlagAssignment ) import Distribution.Client.SourceRepoParse ( sourceRepoFieldDescrs ) import Distribution.Simple.Compiler @@ -46,6 +52,7 @@ ( Flag(Flag), toFlag, fromFlagOrDefault , ConfigFlags(..), configureOptions , HaddockFlags(..), haddockOptions, defaultHaddockFlags + , TestFlags(..), testOptions', defaultTestFlags , programDbPaths', splitArgs ) import Distribution.Client.Setup @@ -63,23 +70,24 @@ import Distribution.Simple.LocalBuildInfo ( toPathTemplate, fromPathTemplate ) -import Distribution.Text -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP - ( ReadP, (+++), (<++) ) -import qualified Text.Read as Read +import Distribution.Deprecated.Text +import qualified Distribution.Deprecated.ReadP as Parse +import Distribution.Deprecated.ReadP + ( ReadP, (+++) ) import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ( Doc, ($+$) ) -import qualified Distribution.ParseUtils as ParseUtils (field) -import Distribution.ParseUtils +import qualified Distribution.Deprecated.ParseUtils as ParseUtils (field) +import Distribution.Deprecated.ParseUtils ( ParseResult(..), PError(..), syntaxError, PWarning(..), warning - , simpleField, commaNewLineListField - , showToken ) + , simpleField, commaNewLineListField, newLineListField, parseTokenQ + , parseHaskellString, showToken ) import Distribution.Client.ParseUtils import Distribution.Simple.Command ( CommandUI(commandOptions), ShowOrParseArgs(..) , OptionField, option, reqArg' ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint ) import qualified Data.Map as Map ------------------------------------------------------------------ @@ -99,7 +107,7 @@ legacyPackages :: [String], legacyPackagesOptional :: [String], legacyPackagesRepo :: [SourceRepo], - legacyPackagesNamed :: [Dependency], + legacyPackagesNamed :: [PackageVersionConstraint], legacySharedConfig :: LegacySharedConfig, legacyAllConfig :: LegacyPackageConfig, @@ -117,7 +125,8 @@ data LegacyPackageConfig = LegacyPackageConfig { legacyConfigureFlags :: ConfigFlags, legacyInstallPkgFlags :: InstallFlags, - legacyHaddockFlags :: HaddockFlags + legacyHaddockFlags :: HaddockFlags, + legacyTestFlags :: TestFlags } deriving Generic instance Monoid LegacyPackageConfig where @@ -131,7 +140,8 @@ legacyGlobalFlags :: GlobalFlags, legacyConfigureShFlags :: ConfigFlags, legacyConfigureExFlags :: ConfigExFlags, - legacyInstallFlags :: InstallFlags + legacyInstallFlags :: InstallFlags, + legacyClientInstallFlags:: ClientInstallFlags } deriving Generic instance Monoid LegacySharedConfig where @@ -155,14 +165,18 @@ -- commandLineFlagsToProjectConfig :: GlobalFlags -> ConfigFlags -> ConfigExFlags - -> InstallFlags -> HaddockFlags + -> InstallFlags -> ClientInstallFlags + -> HaddockFlags + -> TestFlags -> ProjectConfig commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags = + installFlags clientInstallFlags + haddockFlags testFlags = mempty { projectConfigBuildOnly = convertLegacyBuildOnlyFlags globalFlags configFlags - installFlags haddockFlags, + installFlags clientInstallFlags + haddockFlags testFlags, projectConfigShared = convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags, @@ -171,7 +185,7 @@ } where (localConfig, allConfig) = splitConfig (convertLegacyPerPackageFlags - configFlags installFlags haddockFlags) + configFlags installFlags haddockFlags testFlags) -- split the package config (from command line arguments) into -- those applied to all packages and those to local only. -- @@ -209,13 +223,15 @@ SavedConfig { savedGlobalFlags = globalFlags, savedInstallFlags = installFlags, + savedClientInstallFlags= clientInstallFlags, savedConfigureFlags = configFlags, savedConfigureExFlags = configExFlags, savedUserInstallDirs = _, savedGlobalInstallDirs = _, savedUploadFlags = _, savedReportFlags = _, - savedHaddockFlags = haddockFlags + savedHaddockFlags = haddockFlags, + savedTestFlags = testFlags } = mempty { projectConfigBuildOnly = configBuildOnly, @@ -227,16 +243,19 @@ -- defaults in the various resolve functions in terms of the new types. configExFlags' = defaultConfigExFlags <> configExFlags installFlags' = defaultInstallFlags <> installFlags + clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags haddockFlags' = defaultHaddockFlags <> haddockFlags + testFlags' = defaultTestFlags <> testFlags configAllPackages = convertLegacyPerPackageFlags - configFlags installFlags' haddockFlags' + configFlags installFlags' haddockFlags' testFlags' configShared = convertLegacyAllPackageFlags globalFlags configFlags configExFlags' installFlags' configBuildOnly = convertLegacyBuildOnlyFlags globalFlags configFlags - installFlags' haddockFlags' + installFlags' clientInstallFlags' + haddockFlags' testFlags' -- | Convert the project config from the legacy types to the 'ProjectConfig' @@ -251,10 +270,11 @@ legacyPackagesRepo, legacyPackagesNamed, legacySharedConfig = LegacySharedConfig globalFlags configShFlags - configExFlags installSharedFlags, + configExFlags installSharedFlags + clientInstallFlags, legacyAllConfig, legacyLocalConfig = LegacyPackageConfig configFlags installPerPkgFlags - haddockFlags, + haddockFlags testFlags, legacySpecificConfig } = @@ -272,21 +292,23 @@ projectConfigSpecificPackage = fmap perPackage legacySpecificConfig } where - configAllPackages = convertLegacyPerPackageFlags g i h - where LegacyPackageConfig g i h = legacyAllConfig + configAllPackages = convertLegacyPerPackageFlags g i h t + where LegacyPackageConfig g i h t = legacyAllConfig configLocalPackages = convertLegacyPerPackageFlags configFlags installPerPkgFlags haddockFlags + testFlags configPackagesShared= convertLegacyAllPackageFlags globalFlags (configFlags <> configShFlags) configExFlags installSharedFlags configBuildOnly = convertLegacyBuildOnlyFlags globalFlags configShFlags - installSharedFlags haddockFlags + installSharedFlags clientInstallFlags + haddockFlags testFlags perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags - perPkgHaddockFlags) = + perPkgHaddockFlags perPkgTestFlags) = convertLegacyPerPackageFlags - perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags + perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags perPkgTestFlags -- | Helper used by other conversion functions that returns the @@ -341,11 +363,13 @@ --installUpgradeDeps = projectConfigUpgradeDeps, installReorderGoals = projectConfigReorderGoals, installCountConflicts = projectConfigCountConflicts, + installMinimizeConflictSet = projectConfigMinimizeConflictSet, installPerComponent = projectConfigPerComponent, installIndependentGoals = projectConfigIndependentGoals, --installShadowPkgs = projectConfigShadowPkgs, installStrongFlags = projectConfigStrongFlags, - installAllowBootLibInstalls = projectConfigAllowBootLibInstalls + installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, + installOnlyConstrained = projectConfigOnlyConstrained } = installFlags @@ -354,8 +378,8 @@ -- 'PackageConfig' subset of the 'ProjectConfig'. -- convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags - -> PackageConfig -convertLegacyPerPackageFlags configFlags installFlags haddockFlags = + -> TestFlags -> PackageConfig +convertLegacyPerPackageFlags configFlags installFlags haddockFlags testFlags = PackageConfig{..} where ConfigFlags { @@ -367,6 +391,7 @@ configSharedLib = packageConfigSharedLib, configStaticLib = packageConfigStaticLib, configDynExe = packageConfigDynExe, + configFullyStaticExe = packageConfigFullyStaticExe, configProfExe = packageConfigProfExe, configProf = packageConfigProf, configProfDetail = packageConfigProfDetail, @@ -419,18 +444,31 @@ haddockContents = packageConfigHaddockContents } = haddockFlags + TestFlags { + testHumanLog = packageConfigTestHumanLog, + testMachineLog = packageConfigTestMachineLog, + testShowDetails = packageConfigTestShowDetails, + testKeepTix = packageConfigTestKeepTix, + testWrapper = packageConfigTestWrapper, + testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites, + testOptions = packageConfigTestTestOptions + } = testFlags + -- | Helper used by other conversion functions that returns the -- 'ProjectConfigBuildOnly' subset of the 'ProjectConfig'. -- convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags - -> InstallFlags -> HaddockFlags + -> InstallFlags -> ClientInstallFlags + -> HaddockFlags -> TestFlags -> ProjectConfigBuildOnly convertLegacyBuildOnlyFlags globalFlags configFlags - installFlags haddockFlags = + installFlags clientInstallFlags + haddockFlags _ = ProjectConfigBuildOnly{..} where + projectConfigClientInstallFlags = clientInstallFlags GlobalFlags { globalCacheDir = projectConfigCacheDir, globalLogsDir = projectConfigLogsDir, @@ -504,7 +542,8 @@ legacyGlobalFlags = globalFlags, legacyConfigureShFlags = configFlags, legacyConfigureExFlags = configExFlags, - legacyInstallFlags = installFlags + legacyInstallFlags = installFlags, + legacyClientInstallFlags = projectConfigClientInstallFlags } where globalFlags = GlobalFlags { @@ -555,10 +594,12 @@ installUpgradeDeps = mempty, --projectConfigUpgradeDeps, installReorderGoals = projectConfigReorderGoals, installCountConflicts = projectConfigCountConflicts, + installMinimizeConflictSet = projectConfigMinimizeConflictSet, installIndependentGoals = projectConfigIndependentGoals, installShadowPkgs = mempty, --projectConfigShadowPkgs, installStrongFlags = projectConfigStrongFlags, installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, + installOnlyConstrained = projectConfigOnlyConstrained, installOnly = mempty, installOnlyDeps = projectConfigOnlyDeps, installIndexState = projectConfigIndexState, @@ -588,7 +629,8 @@ LegacyPackageConfig { legacyConfigureFlags = configFlags, legacyInstallPkgFlags= mempty, - legacyHaddockFlags = haddockFlags + legacyHaddockFlags = haddockFlags, + legacyTestFlags = mempty } where configFlags = ConfigFlags { @@ -606,6 +648,7 @@ configSharedLib = mempty, configStaticLib = mempty, configDynExe = mempty, + configFullyStaticExe = mempty, configProfExe = mempty, configProf = mempty, configProfDetail = mempty, @@ -643,7 +686,8 @@ configFlagError = mempty, --TODO: ??? configRelocatable = mempty, configDebugInfo = mempty, - configUseResponseFiles = mempty + configUseResponseFiles = mempty, + configAllowDependingOnPrivateLibs = mempty } haddockFlags = mempty { @@ -656,7 +700,8 @@ LegacyPackageConfig { legacyConfigureFlags = configFlags, legacyInstallPkgFlags = installFlags, - legacyHaddockFlags = haddockFlags + legacyHaddockFlags = haddockFlags, + legacyTestFlags = testFlags } where configFlags = ConfigFlags { @@ -674,6 +719,7 @@ configSharedLib = packageConfigSharedLib, configStaticLib = packageConfigStaticLib, configDynExe = packageConfigDynExe, + configFullyStaticExe = packageConfigFullyStaticExe, configProfExe = packageConfigProfExe, configProf = packageConfigProf, configProfDetail = packageConfigProfDetail, @@ -711,7 +757,8 @@ configFlagError = mempty, --TODO: ??? configRelocatable = packageConfigRelocatable, configDebugInfo = packageConfigDebugInfo, - configUseResponseFiles = mempty + configUseResponseFiles = mempty, + configAllowDependingOnPrivateLibs = mempty } installFlags = mempty { @@ -743,7 +790,19 @@ haddockArgs = mempty } + testFlags = TestFlags { + testDistPref = mempty, + testVerbosity = mempty, + testHumanLog = packageConfigTestHumanLog, + testMachineLog = packageConfigTestMachineLog, + testShowDetails = packageConfigTestShowDetails, + testKeepTix = packageConfigTestKeepTix, + testWrapper = packageConfigTestWrapper, + testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites, + testOptions = packageConfigTestTestOptions + } + ------------------------------------------------ -- Parsing and showing the project config file -- @@ -918,11 +977,18 @@ , "remote-build-reporting", "report-planning-failure" , "one-shot", "jobs", "keep-going", "offline", "per-component" -- solver flags: - , "max-backjumps", "reorder-goals", "count-conflicts", "independent-goals" - , "strong-flags" , "allow-boot-library-installs", "index-state" + , "max-backjumps", "reorder-goals", "count-conflicts" + , "minimize-conflict-set", "independent-goals" + , "strong-flags" , "allow-boot-library-installs", "reject-unconstrained-dependencies", "index-state" ] . commandOptionsToFields ) (installOptions ParseArgs) + ++ + ( liftFields + legacyClientInstallFlags + (\flags conf -> conf { legacyClientInstallFlags = flags }) + . commandOptionsToFields + ) (clientInstallOptions ParseArgs) where constraintSrc = ConstraintSourceProjectConfig "TODO" @@ -962,7 +1028,7 @@ [ "with-compiler", "with-hc-pkg" , "program-prefix", "program-suffix" , "library-vanilla", "library-profiling" - , "shared", "static", "executable-dynamic" + , "shared", "static", "executable-dynamic", "executable-static" , "profiling", "executable-profiling" , "profiling-detail", "library-profiling-detail" , "library-for-ghci", "split-objs", "split-sections" @@ -1014,7 +1080,25 @@ ] . commandOptionsToFields ) (haddockOptions ParseArgs) + ++ + ( liftFields + legacyTestFlags + (\flags conf -> conf { legacyTestFlags = flags }) + . mapFieldNames + prefixTest + . addFields + [ newLineListField "test-options" + (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) + testOptions + (\v conf -> conf { testOptions = v }) + ] + . filterFields + [ "log", "machine-log", "show-details", "keep-tix-files" + , "fail-when-no-test-suites", "test-wrapper" ] + . commandOptionsToFields + ) (testOptions' ParseArgs) + where overrideFieldCompiler = simpleField "compiler" @@ -1077,7 +1161,10 @@ caseWarning = PWarning $ "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.") + prefixTest name | "test-" `isPrefixOf` name = name + | otherwise = "test-" ++ name + legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig] legacyPackageConfigSectionDescrs = [ packageRepoSectionDescr @@ -1305,26 +1392,6 @@ -- Local field utils -- ---TODO: [code cleanup] all these utils should move to Distribution.ParseUtils --- either augmenting or replacing the ones there - ---TODO: [code cleanup] this is a different definition from listField, like --- commaNewLineListField it pretty prints on multiple lines -newLineListField :: String -> (a -> Doc) -> ReadP [a] a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -newLineListField = listFieldWithSep Disp.sep - ---TODO: [code cleanup] local copy purely so we can use the fixed version --- of parseOptCommaList below -listFieldWithSep :: ([Doc] -> Doc) -> String -> (a -> Doc) -> ReadP [a] a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -listFieldWithSep separator name showF readF get' set = - liftField get' set' $ - ParseUtils.field name showF' (parseOptCommaList readF) - where - set' xs b = set (get' b ++ xs) b - showF' = separator . map showF - -- | Parser combinator for simple fields which uses the field type's -- 'Monoid' instance for combining multiple occurences of the field. monoidField :: Monoid a => String -> (a -> Doc) -> ReadP a a @@ -1334,15 +1401,6 @@ where set' xs b = set (get' b `mappend` xs) b ---TODO: [code cleanup] local redefinition that should replace the version in --- D.ParseUtils. This version avoid parse ambiguity for list element parsers --- that have multiple valid parses of prefixes. -parseOptCommaList :: ReadP r a -> ReadP r [a] -parseOptCommaList p = Parse.sepBy p sep - where - -- The separator must not be empty or it introduces ambiguity - sep = (Parse.skipSpaces >> Parse.char ',' >> Parse.skipSpaces) - +++ (Parse.satisfy isSpace >> Parse.skipSpaces) --TODO: [code cleanup] local redefinition that should replace the version in -- D.ParseUtils called showFilePath. This version escapes "." and "--" which @@ -1353,19 +1411,6 @@ showTokenQ x@('.':[]) = Disp.text (show x) showTokenQ x = showToken x --- This is just a copy of parseTokenQ, using the fixed parseHaskellString -parseTokenQ :: ReadP r String -parseTokenQ = parseHaskellString - <++ Parse.munch1 (\x -> not (isSpace x) && x /= ',') - ---TODO: [code cleanup] use this to replace the parseHaskellString in --- Distribution.ParseUtils. It turns out Read instance for String accepts --- the ['a', 'b'] syntax, which we do not want. In particular it messes --- up any token starting with []. -parseHaskellString :: ReadP r String -parseHaskellString = - Parse.readS_to_P $ - Read.readPrec_to_S (do Read.String s <- Read.lexP; return s) 0 -- Handy util addFields :: [FieldDescr a] diff --git a/Distribution/Client/ProjectConfig/Types.hs b/Distribution/Client/ProjectConfig/Types.hs --- a/Distribution/Client/ProjectConfig/Types.hs +++ b/Distribution/Client/ProjectConfig/Types.hs @@ -33,12 +33,16 @@ import Distribution.Client.IndexUtils.Timestamp ( IndexState ) +import Distribution.Client.CmdInstall.ClientInstallFlags + ( ClientInstallFlags(..) ) + import Distribution.Solver.Types.Settings import Distribution.Solver.Types.ConstraintSource import Distribution.Package ( PackageName, PackageId, UnitId ) -import Distribution.Types.Dependency +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint ) import Distribution.Version ( Version ) import Distribution.System @@ -49,7 +53,7 @@ ( Compiler, CompilerFlavor , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) ) import Distribution.Simple.Setup - ( Flag, HaddockTarget(..) ) + ( Flag, HaddockTarget(..), TestShowDetails(..) ) import Distribution.Simple.InstallDirs ( PathTemplate ) import Distribution.Utils.NubList @@ -106,7 +110,7 @@ projectPackagesRepo :: [SourceRepo], -- | Packages in this project from hackage repositories. - projectPackagesNamed :: [Dependency], + projectPackagesNamed :: [PackageVersionConstraint], -- See respective types for an explanation of what these -- values are about: @@ -148,7 +152,8 @@ projectConfigHttpTransport :: Flag String, projectConfigIgnoreExpiry :: Flag Bool, projectConfigCacheDir :: Flag FilePath, - projectConfigLogsDir :: Flag FilePath + projectConfigLogsDir :: Flag FilePath, + projectConfigClientInstallFlags :: ClientInstallFlags } deriving (Eq, Show, Generic) @@ -182,7 +187,7 @@ -- solver configuration projectConfigConstraints :: [(UserConstraint, ConstraintSource)], - projectConfigPreferences :: [Dependency], + projectConfigPreferences :: [PackageVersionConstraint], projectConfigCabalVersion :: Flag Version, --TODO: [required eventually] unused projectConfigSolver :: Flag PreSolver, projectConfigAllowOlder :: Maybe AllowOlder, @@ -192,8 +197,10 @@ projectConfigMaxBackjumps :: Flag Int, projectConfigReorderGoals :: Flag ReorderGoals, projectConfigCountConflicts :: Flag CountConflicts, + projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet, projectConfigStrongFlags :: Flag StrongFlags, projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls, + projectConfigOnlyConstrained :: Flag OnlyConstrained, projectConfigPerComponent :: Flag Bool, projectConfigIndependentGoals :: Flag IndependentGoals, @@ -239,6 +246,7 @@ packageConfigSharedLib :: Flag Bool, packageConfigStaticLib :: Flag Bool, packageConfigDynExe :: Flag Bool, + packageConfigFullyStaticExe :: Flag Bool, packageConfigProf :: Flag Bool, --TODO: [code cleanup] sort out packageConfigProfLib :: Flag Bool, -- this duplication packageConfigProfExe :: Flag Bool, -- and consistency @@ -263,6 +271,7 @@ packageConfigDebugInfo :: Flag DebugInfoLevel, packageConfigRunTests :: Flag Bool, --TODO: [required eventually] use this packageConfigDocumentation :: Flag Bool, --TODO: [required eventually] use this + -- Haddock options packageConfigHaddockHoogle :: Flag Bool, --TODO: [required eventually] use this packageConfigHaddockHtml :: Flag Bool, --TODO: [required eventually] use this packageConfigHaddockHtmlLocation :: Flag String, --TODO: [required eventually] use this @@ -276,7 +285,15 @@ packageConfigHaddockQuickJump :: Flag Bool, --TODO: [required eventually] use this packageConfigHaddockHscolourCss :: Flag FilePath, --TODO: [required eventually] use this packageConfigHaddockContents :: Flag PathTemplate, --TODO: [required eventually] use this - packageConfigHaddockForHackage :: Flag HaddockTarget + packageConfigHaddockForHackage :: Flag HaddockTarget, + -- Test options + packageConfigTestHumanLog :: Flag PathTemplate, + packageConfigTestMachineLog :: Flag PathTemplate, + packageConfigTestShowDetails :: Flag TestShowDetails, + packageConfigTestKeepTix :: Flag Bool, + packageConfigTestWrapper :: Flag FilePath, + packageConfigTestFailWhenNoTestSuites :: Flag Bool, + packageConfigTestTestOptions :: [PathTemplate] } deriving (Eq, Show, Generic) @@ -363,7 +380,7 @@ solverSettingRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers. solverSettingLocalRepos :: [FilePath], solverSettingConstraints :: [(UserConstraint, ConstraintSource)], - solverSettingPreferences :: [Dependency], + solverSettingPreferences :: [PackageVersionConstraint], solverSettingFlagAssignment :: FlagAssignment, -- ^ For all local packages solverSettingFlagAssignments :: Map PackageName FlagAssignment, solverSettingCabalVersion :: Maybe Version, --TODO: [required eventually] unused @@ -373,8 +390,10 @@ solverSettingMaxBackjumps :: Maybe Int, solverSettingReorderGoals :: ReorderGoals, solverSettingCountConflicts :: CountConflicts, + solverSettingMinimizeConflictSet :: MinimizeConflictSet, solverSettingStrongFlags :: StrongFlags, solverSettingAllowBootLibInstalls :: AllowBootLibInstalls, + solverSettingOnlyConstrained :: OnlyConstrained, solverSettingIndexState :: Maybe IndexState, solverSettingIndependentGoals :: IndependentGoals -- Things that only make sense for manual mode, not --local mode diff --git a/Distribution/Client/ProjectOrchestration.hs b/Distribution/Client/ProjectOrchestration.hs --- a/Distribution/Client/ProjectOrchestration.hs +++ b/Distribution/Client/ProjectOrchestration.hs @@ -41,6 +41,7 @@ -- module Distribution.Client.ProjectOrchestration ( -- * Discovery phase: what is in the project? + CurrentCommand(..), establishProjectBaseContext, ProjectBaseContext(..), BuildTimeSettings(..), @@ -135,7 +136,6 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Package - hiding (InstalledPackageId, installedPackageId) import Distribution.PackageDescription ( FlagAssignment, unFlagAssignment, showFlagValue , diffFlagAssignment ) @@ -152,7 +152,8 @@ import Distribution.Verbosity import Distribution.Version ( mkVersion ) -import Distribution.Text +import Distribution.Pretty + ( prettyShow ) import Distribution.Simple.Compiler ( compilerCompatVersion, showCompilerId , OptimisationLevel(..)) @@ -168,6 +169,11 @@ #endif +-- | Tracks what command is being executed, because we need to hide this somewhere +-- for cases that need special handling (usually for error reporting). +data CurrentCommand = InstallCommand | HaddockCommand | OtherCommand + deriving (Show, Eq) + -- | This holds the context of a project prior to solving: the content of the -- @cabal.project@ and all the local package @.cabal@ files. -- @@ -176,13 +182,15 @@ cabalDirLayout :: CabalDirLayout, projectConfig :: ProjectConfig, localPackages :: [PackageSpecifier UnresolvedSourcePackage], - buildSettings :: BuildTimeSettings + buildSettings :: BuildTimeSettings, + currentCommand :: CurrentCommand } establishProjectBaseContext :: Verbosity -> ProjectConfig + -> CurrentCommand -> IO ProjectBaseContext -establishProjectBaseContext verbosity cliConfig = do +establishProjectBaseContext verbosity cliConfig currentCommand = do cabalDir <- getCabalDir projectRoot <- either throwIO return =<< @@ -205,7 +213,8 @@ } = projectConfigShared projectConfig mlogsDir = Setup.flagToMaybe projectConfigLogsDir - mstoreDir <- sequenceA $ makeAbsolute <$> Setup.flagToMaybe projectConfigStoreDir + mstoreDir <- sequenceA $ makeAbsolute + <$> Setup.flagToMaybe projectConfigStoreDir let cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir buildSettings = resolveBuildTimeSettings @@ -217,7 +226,8 @@ cabalDirLayout, projectConfig, localPackages, - buildSettings + buildSettings, + currentCommand } where mdistDirectory = Setup.flagToMaybe projectConfigDistDir @@ -403,7 +413,7 @@ $ projectConfig shouldWriteGhcEnvironment = - case fromFlagOrDefault WriteGhcEnvironmentFilesOnlyForGhc844AndNewer + case fromFlagOrDefault NeverWriteGhcEnvironmentFiles writeGhcEnvFilesPolicy of AlwaysWriteGhcEnvironmentFiles -> True @@ -421,7 +431,7 @@ -- Finally if there were any build failures then report them and throw -- an exception to terminate the program - dieOnBuildFailures verbosity elaboratedPlanToExecute buildOutcomes + dieOnBuildFailures verbosity currentCommand elaboratedPlanToExecute buildOutcomes -- Note that it is a deliberate design choice that the 'buildTargets' is -- not passed to phase 1, and the various bits of input config is not @@ -664,17 +674,19 @@ in (pname, cname')) availableTargetsByPackageIdAndComponentName where - unqualComponentName :: PackageName -> ComponentName -> UnqualComponentName + unqualComponentName :: + PackageName -> ComponentName -> UnqualComponentName unqualComponentName pkgname = fromMaybe (packageNameToUnqualComponentName pkgname) . componentNameString -- Add in all the empty packages. These do not appear in the - -- availableTargetsByComponent map, since that only contains components - -- so packages with no components are invisible from that perspective. - -- The empty packages need to be there for proper error reporting, so users - -- can select the empty package and then we can report that it is empty, - -- otherwise we falsely report there is no such package at all. + -- availableTargetsByComponent map, since that only contains + -- components, so packages with no components are invisible from + -- that perspective. The empty packages need to be there for + -- proper error reporting, so users can select the empty package + -- and then we can report that it is empty, otherwise we falsely + -- report there is no such package at all. availableTargetsEmptyPackages = Map.fromList [ (packageId pkg, []) @@ -684,9 +696,10 @@ ElabPackage _ -> null (pkgComponents (elabPkgDescription pkg)) ] - --TODO: [research required] what if the solution has multiple versions of this package? - -- e.g. due to setup deps or due to multiple independent sets of - -- packages being built (e.g. ghc + ghcjs in a project) + --TODO: [research required] what if the solution has multiple + -- versions of this package? + -- e.g. due to setup deps or due to multiple independent sets + -- of packages being built (e.g. ghc + ghcjs in a project) filterTargetsKind :: ComponentKind -> [AvailableTarget k] -> [AvailableTarget k] filterTargetsKind ckind = filterTargetsKindWith (== ckind) @@ -759,13 +772,22 @@ data TargetProblemCommon = TargetNotInProject PackageName | TargetAvailableInIndex PackageName - | TargetComponentNotProjectLocal PackageId ComponentName SubComponentTarget - | TargetComponentNotBuildable PackageId ComponentName SubComponentTarget - | TargetOptionalStanzaDisabledByUser PackageId ComponentName SubComponentTarget - | TargetOptionalStanzaDisabledBySolver PackageId ComponentName SubComponentTarget - | TargetProblemUnknownComponent PackageName - (Either UnqualComponentName ComponentName) + | TargetComponentNotProjectLocal + PackageId ComponentName SubComponentTarget + + | TargetComponentNotBuildable + PackageId ComponentName SubComponentTarget + + | TargetOptionalStanzaDisabledByUser + PackageId ComponentName SubComponentTarget + + | TargetOptionalStanzaDisabledBySolver + PackageId ComponentName SubComponentTarget + + | TargetProblemUnknownComponent + PackageName (Either UnqualComponentName ComponentName) + -- The target matching stuff only returns packages local to the project, -- so these lookups should never fail, but if 'resolveTargets' is called -- directly then of course it can. @@ -810,7 +832,8 @@ ProjectBaseContext { buildSettings = BuildTimeSettings{buildSettingDryRun}, projectConfig = ProjectConfig { - projectConfigLocalPackages = PackageConfig {packageConfigOptimization} + projectConfigLocalPackages = + PackageConfig {packageConfigOptimization} } } ProjectBuildContext { @@ -824,8 +847,9 @@ | otherwise = noticeNoWrap verbosity $ unlines $ - (showBuildProfile ++ "In order, the following " ++ wouldWill ++ " be built" ++ - ifNormal " (use -v for more details)" ++ ":") + (showBuildProfile ++ "In order, the following " + ++ wouldWill ++ " be built" + ++ ifNormal " (use -v for more details)" ++ ":") : map showPkgAndReason pkgs where @@ -844,8 +868,8 @@ showPkgAndReason (ReadyPackage elab) = " - " ++ (if verbosity >= deafening - then display (installedUnitId elab) - else display (packageId elab) + then prettyShow (installedUnitId elab) + else prettyShow (packageId elab) ) ++ (case elabPkgOrComp elab of ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas pkg) @@ -858,17 +882,18 @@ " (" ++ showBuildStatus buildStatus ++ ")" showComp elab comp = - maybe "custom" display (compComponentName comp) ++ + maybe "custom" prettyShow (compComponentName comp) ++ if Map.null (elabInstantiatedWith elab) then "" else " with " ++ intercalate ", " -- TODO: Abbreviate the UnitIds - [ display k ++ "=" ++ display v + [ prettyShow k ++ "=" ++ prettyShow v | (k,v) <- Map.toList (elabInstantiatedWith elab) ] nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment - nonDefaultFlags elab = elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab + nonDefaultFlags elab = + elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab showStanzas pkg = concat $ [ " *test" @@ -879,8 +904,10 @@ showTargets elab | null (elabBuildTargets elab) = "" | otherwise - = " (" ++ intercalate ", " [ showComponentTarget (packageId elab) t | t <- elabBuildTargets elab ] - ++ ")" + = " (" + ++ intercalate ", " [ showComponentTarget (packageId elab) t + | t <- elabBuildTargets elab ] + ++ ")" showFlagAssignment :: FlagAssignment -> String showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment @@ -897,8 +924,11 @@ -- rendering. nubFlag :: Eq a => a -> Setup.Flag a -> Setup.Flag a nubFlag x (Setup.Flag x') | x == x' = Setup.NoFlag - nubFlag _ f = f - (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling fullConfigureFlags + nubFlag _ f = f + + (tryLibProfiling, tryExeProfiling) = + computeEffectiveProfiling fullConfigureFlags + partialConfigureFlags = Mon.mempty { configProf = @@ -932,10 +962,12 @@ BuildReasonEphemeralTargets -> "ephemeral targets" BuildStatusUpToDate {} -> "up to date" -- doesn't happen - showMonitorChangedReason (MonitoredFileChanged file) = "file " ++ file ++ " changed" + showMonitorChangedReason (MonitoredFileChanged file) = + "file " ++ file ++ " changed" showMonitorChangedReason (MonitoredValueChanged _) = "value changed" - showMonitorChangedReason MonitorFirstRun = "first run" - showMonitorChangedReason MonitorCorruptCache = "cannot read state cache" + showMonitorChangedReason MonitorFirstRun = "first run" + showMonitorChangedReason MonitorCorruptCache = + "cannot read state cache" showBuildProfile = "Build profile: " ++ unwords [ "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared, @@ -948,9 +980,9 @@ -- | If there are build failures then report them and throw an exception. -- -dieOnBuildFailures :: Verbosity +dieOnBuildFailures :: Verbosity -> CurrentCommand -> ElaboratedInstallPlan -> BuildOutcomes -> IO () -dieOnBuildFailures verbosity plan buildOutcomes +dieOnBuildFailures verbosity currentCommand plan buildOutcomes | null failures = return () | isSimpleCase = exitFailure @@ -998,12 +1030,16 @@ ] dieIfNotHaddockFailure + | currentCommand == HaddockCommand = die' | all isHaddockFailure failuresClassification = warn | otherwise = die' where - isHaddockFailure (_, ShowBuildSummaryOnly (HaddocksFailed _) ) = True - isHaddockFailure (_, ShowBuildSummaryAndLog (HaddocksFailed _) _) = True - isHaddockFailure _ = False + isHaddockFailure + (_, ShowBuildSummaryOnly (HaddocksFailed _) ) = True + isHaddockFailure + (_, ShowBuildSummaryAndLog (HaddocksFailed _) _) = True + isHaddockFailure + _ = False classifyBuildFailure :: BuildFailure -> BuildFailurePresentation @@ -1023,10 +1059,10 @@ -- context which package failed. -- -- We generalise this rule as follows: - -- - if only one failure occurs, and it is in a single root package (ie a - -- package with nothing else depending on it) - -- - and that failure is of a kind that always reports enough detail - -- itself (e.g. ghc reporting errors on stdout) + -- - if only one failure occurs, and it is in a single root + -- package (i.e. a package with nothing else depending on it) + -- - and that failure is of a kind that always reports enough + -- detail itself (e.g. ghc reporting errors on stdout) -- - then we do not report additional error detail or context. -- isSimpleCase @@ -1034,6 +1070,7 @@ , [pkg] <- rootpkgs , installedUnitId pkg == pkgid , isFailureSelfExplanatory (buildFailureReason failure) + , currentCommand /= InstallCommand = True | otherwise = False @@ -1078,8 +1115,8 @@ BenchFailed _ -> "Benchmarks failed for " ++ pkgstr InstallFailed _ -> "Failed to build " ++ pkgstr DependentFailed depid - -> "Failed to build " ++ display (packageId pkg) - ++ " because it depends on " ++ display depid + -> "Failed to build " ++ prettyShow (packageId pkg) + ++ " because it depends on " ++ prettyShow depid ++ " which itself failed to build" where pkgstr = elabConfiguredName verbosity pkg @@ -1087,21 +1124,25 @@ then renderDependencyOf (installedUnitId pkg) else "" - renderFailureExtraDetail reason = - case reason of - ConfigureFailed _ -> " The failure occurred during the configure step." - InstallFailed _ -> " The failure occurred during the final install step." - _ -> "" + renderFailureExtraDetail (ConfigureFailed _) = + " The failure occurred during the configure step." + renderFailureExtraDetail (InstallFailed _) = + " The failure occurred during the final install step." + renderFailureExtraDetail _ = + "" renderDependencyOf pkgid = case ultimateDeps pkgid of [] -> "" - (p1:[]) -> " (which is required by " ++ elabPlanPackageName verbosity p1 ++ ")" - (p1:p2:[]) -> " (which is required by " ++ elabPlanPackageName verbosity p1 - ++ " and " ++ elabPlanPackageName verbosity p2 ++ ")" - (p1:p2:_) -> " (which is required by " ++ elabPlanPackageName verbosity p1 - ++ ", " ++ elabPlanPackageName verbosity p2 - ++ " and others)" + (p1:[]) -> + " (which is required by " ++ elabPlanPackageName verbosity p1 ++ ")" + (p1:p2:[]) -> + " (which is required by " ++ elabPlanPackageName verbosity p1 + ++ " and " ++ elabPlanPackageName verbosity p2 ++ ")" + (p1:p2:_) -> + " (which is required by " ++ elabPlanPackageName verbosity p1 + ++ ", " ++ elabPlanPackageName verbosity p2 + ++ " and others)" showException e = case fromException e of Just (ExitFailure 1) -> "" @@ -1136,9 +1177,10 @@ ++ " which may be because some part of it was killed " ++ "(i.e. SIGKILL). " ++ explanation where - explanation = "The typical reason for this is that there is not " - ++ "enough memory available (e.g. the OS killed a process " - ++ "using lots of memory)." + explanation = + "The typical reason for this is that there is not " + ++ "enough memory available (e.g. the OS killed a process " + ++ "using lots of memory)." #endif Just (ExitFailure n) -> " The build process terminated with exit code " ++ show n diff --git a/Distribution/Client/ProjectPlanOutput.hs b/Distribution/Client/ProjectPlanOutput.hs --- a/Distribution/Client/ProjectPlanOutput.hs +++ b/Distribution/Client/ProjectPlanOutput.hs @@ -40,7 +40,7 @@ ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles) , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile , writeGhcEnvironmentFile ) -import Distribution.Text +import Distribution.Deprecated.Text import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph (Graph, Node) import qualified Distribution.Compat.Binary as Binary diff --git a/Distribution/Client/ProjectPlanning.hs b/Distribution/Client/ProjectPlanning.hs --- a/Distribution/Client/ProjectPlanning.hs +++ b/Distribution/Client/ProjectPlanning.hs @@ -62,7 +62,9 @@ -- * Path construction binDirectoryFor, - binDirectories + binDirectories, + storePackageInstallDirs, + storePackageInstallDirs' ) where import Prelude () @@ -108,10 +110,13 @@ import Distribution.Solver.Types.Settings import Distribution.ModuleName -import Distribution.Package hiding - (InstalledPackageId, installedPackageId) +import Distribution.Package import Distribution.Types.AnnotatedId import Distribution.Types.ComponentName +import Distribution.Types.LibraryName +import Distribution.Types.GivenComponent + (GivenComponent(..)) +import Distribution.Types.PackageVersionConstraint import Distribution.Types.PkgconfigDependency import Distribution.Types.UnqualComponentName import Distribution.System @@ -127,7 +132,7 @@ import Distribution.Simple.Program.Find import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Setup - (Flag, toFlag, flagToMaybe, flagToList, fromFlagOrDefault) + (Flag(..), toFlag, flagToMaybe, flagToList, fromFlagOrDefault) import qualified Distribution.Simple.Configure as Cabal import qualified Distribution.Simple.LocalBuildInfo as Cabal import Distribution.Simple.LocalBuildInfo @@ -147,7 +152,7 @@ import Distribution.Simple.Utils import Distribution.Version import Distribution.Verbosity -import Distribution.Text +import Distribution.Deprecated.Text import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph(IsNode(..)) @@ -259,8 +264,7 @@ assert (elabBuildStyle == BuildInplaceOnly || case compComponentName of Nothing -> True - Just CLibName -> True - Just (CSubLibName _) -> True + Just (CLibName _) -> True Just (CExeName _) -> True -- This is interesting: there's no way to declare a dependency -- on a foreign library at the moment, but you may still want @@ -935,8 +939,9 @@ where - --TODO: [nice to have] disable multiple instances restriction in the solver, but then - -- make sure we can cope with that in the output. + --TODO: [nice to have] disable multiple instances restriction in + -- the solver, but then make sure we can cope with that in the + -- output. resolverParams = setMaxBackjumps solverSettingMaxBackjumps @@ -947,21 +952,28 @@ . setCountConflicts solverSettingCountConflicts - --TODO: [required eventually] should only be configurable for custom installs + . setMinimizeConflictSet solverSettingMinimizeConflictSet + + --TODO: [required eventually] should only be configurable for + --custom installs -- . setAvoidReinstalls solverSettingAvoidReinstalls - --TODO: [required eventually] should only be configurable for custom installs + --TODO: [required eventually] should only be configurable for + --custom installs -- . setShadowPkgs solverSettingShadowPkgs . setStrongFlags solverSettingStrongFlags . setAllowBootLibInstalls solverSettingAllowBootLibInstalls + . setOnlyConstrained solverSettingOnlyConstrained + . setSolverVerbosity verbosity - --TODO: [required eventually] decide if we need to prefer installed for - -- global packages, or prefer latest even for global packages. Perhaps - -- should be configurable but with a different name than "upgrade-dependencies". + --TODO: [required eventually] decide if we need to prefer + -- installed for global packages, or prefer latest even for + -- global packages. Perhaps should be configurable but with a + -- different name than "upgrade-dependencies". . setPreferenceDefault PreferLatestForSelected {-(if solverSettingUpgradeDeps then PreferAllLatest @@ -980,7 +992,7 @@ . addPreferences -- preferences from the config file or command line [ PackageVersionPreference name ver - | Dependency name ver <- solverSettingPreferences ] + | PackageVersionConstraint name ver <- solverSettingPreferences ] . addConstraints -- version constraints from the config file or command line @@ -1060,12 +1072,12 @@ -- current and past compilers; in fact recent lib:Cabal versions -- will warn when they encounter a too new or unknown GHC compiler -- version (c.f. #415). To avoid running into unsupported - -- configurations we encode the compatiblity matrix as lower + -- configurations we encode the compatibility matrix as lower -- bounds on lib:Cabal here (effectively corresponding to the -- respective major Cabal version bundled with the respective GHC -- release). -- - -- GHC 8.4 needs Cabal >= 2.4 + -- GHC 8.6 needs Cabal >= 2.4 -- GHC 8.4 needs Cabal >= 2.2 -- GHC 8.2 needs Cabal >= 2.0 -- GHC 8.0 needs Cabal >= 1.24 @@ -1347,7 +1359,7 @@ -- supported in per-package mode. If this is the case, we should -- give an error when this occurs. checkPerPackageOk comps reasons = do - let is_sublib (CSubLibName _) = True + let is_sublib (CLibName (LSubLibName _)) = True is_sublib _ = False when (any (matchElabPkg is_sublib) comps) $ dieProgress $ @@ -1576,7 +1588,7 @@ -- returns at most one result. elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage]) -> SolverId -> [ElaboratedPlanPackage] - elaborateLibSolverId mapDep = filter (matchPlanPkg (== CLibName)) . mapDep + elaborateLibSolverId mapDep = filter (matchPlanPkg (== (CLibName LMainLibName))) . mapDep -- | Given an 'ElaboratedPlanPackage', return the paths to where the -- executables that this package represents would be installed. @@ -1631,7 +1643,7 @@ elabModuleShape = modShape } - modShape = case find (matchElabPkg (== CLibName)) comps of + modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of Nothing -> emptyModuleShape Just e -> Ty.elabModuleShape e @@ -1671,10 +1683,9 @@ | Graph.N _ cn _ <- fromMaybe [] mb_closure ] where mb_closure = Graph.revClosure compGraph [ k | k <- Graph.keys compGraph, is_lib k ] - is_lib CLibName = True - -- NB: this case should not occur, because sub-libraries + -- NB: the sublib case should not occur, because sub-libraries -- are not supported without per-component builds - is_lib (CSubLibName _) = True + is_lib (CLibName _) = True is_lib _ = False buildComponentDeps f @@ -1809,6 +1820,7 @@ elabSharedLib = pkgid `Set.member` pkgsUseSharedLibrary elabStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib elabDynExe = perPkgOptionFlag pkgid False packageConfigDynExe + elabFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe elabGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still elabProfExe = perPkgOptionFlag pkgid False packageConfigProf @@ -1867,6 +1879,14 @@ elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents + elabTestMachineLog = perPkgOptionMaybe pkgid packageConfigTestMachineLog + elabTestHumanLog = perPkgOptionMaybe pkgid packageConfigTestHumanLog + elabTestShowDetails = perPkgOptionMaybe pkgid packageConfigTestShowDetails + elabTestKeepTix = perPkgOptionFlag pkgid False packageConfigTestKeepTix + elabTestWrapper = perPkgOptionMaybe pkgid packageConfigTestWrapper + elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites + elabTestTestOptions = perPkgOptionList pkgid packageConfigTestTestOptions + perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] @@ -2008,10 +2028,7 @@ -- | Get the appropriate 'ComponentName' which identifies an installed -- component. ipiComponentName :: IPI.InstalledPackageInfo -> ComponentName -ipiComponentName ipkg = - case IPI.sourceLibName ipkg of - Nothing -> CLibName - Just n -> (CSubLibName n) +ipiComponentName = CLibName . IPI.sourceLibName -- | Given a 'ElaboratedConfiguredPackage', report if it matches a -- 'ComponentName'. @@ -2214,6 +2231,41 @@ indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage indefiniteComponent _uid cid + -- Only need Configured; this phase happens before improvement, so + -- there shouldn't be any Installed packages here. + | Just (InstallPlan.Configured epkg) <- Map.lookup cid cmap + , ElabComponent elab_comp <- elabPkgOrComp epkg + = do -- We need to do a little more processing of the includes: some + -- of them are fully definite even without substitution. We + -- want to build those too; see #5634. + -- + -- This code mimics similar code in Distribution.Backpack.ReadyComponent; + -- however, unlike the conversion from LinkedComponent to + -- ReadyComponent, this transformation is done *without* + -- changing the type in question; and what we are simply + -- doing is enforcing tighter invariants on the data + -- structure in question. The new invariant is that there + -- is no IndefFullUnitId in compLinkedLibDependencies that actually + -- has no holes. We couldn't specify this invariant when + -- we initially created the ElaboratedPlanPackage because + -- we have no way of actually refiying the UnitId into a + -- DefiniteUnitId (that's what substUnitId does!) + new_deps <- forM (compLinkedLibDependencies elab_comp) $ \uid -> + if Set.null (openUnitIdFreeHoles uid) + then fmap DefiniteUnitId (substUnitId Map.empty uid) + else return uid + return $ InstallPlan.Configured epkg { + elabPkgOrComp = ElabComponent elab_comp { + compLinkedLibDependencies = new_deps, + -- I think this is right: any new definite unit ids we + -- minted in the phase above need to be built before us. + -- Add 'em in. This doesn't remove any old dependencies + -- on the indefinite package; they're harmless. + compOrderLibDependencies = + ordNub $ compOrderLibDependencies elab_comp ++ + [unDefUnitId d | DefiniteUnitId d <- new_deps] + } + } | Just planpkg <- Map.lookup cid cmap = return planpkg | otherwise = error ("indefiniteComponent: " ++ display cid) @@ -2340,7 +2392,7 @@ AvailableTarget (UnitId, ComponentName))] availableInstalledTargets ipkg = let unitid = installedUnitId ipkg - cname = CLibName + cname = CLibName LMainLibName status = TargetBuildable (unitid, cname) TargetRequestedByDefault target = AvailableTarget (packageId ipkg) cname status False fake = False @@ -2446,7 +2498,7 @@ compComponentName elabComponent == Just cname ElabPackage _ -> case componentName component of - CLibName -> True + CLibName (LMainLibName) -> True CExeName _ -> True --TODO: what about sub-libs and foreign libs? _ -> False @@ -2829,7 +2881,7 @@ } where libTargetsRequiredForRevDeps = - [ ComponentTarget Cabal.defaultLibName WholeComponent + [ ComponentTarget (CLibName Cabal.defaultLibName) WholeComponent | installedUnitId elab `Set.member` hasReverseLibDeps ] exeTargetsRequiredForRevDeps = @@ -3008,9 +3060,9 @@ -- of other packages. SetupCustomImplicitDeps -> Just $ - [ Dependency depPkgname anyVersion + [ Dependency depPkgname anyVersion (Set.singleton LMainLibName) | depPkgname <- legacyCustomSetupPkgs compiler platform ] ++ - [ Dependency cabalPkgname cabalConstraint + [ Dependency cabalPkgname cabalConstraint (Set.singleton LMainLibName) | packageName pkg /= cabalPkgname ] where -- The Cabal dep is slightly special: @@ -3033,8 +3085,8 @@ -- external Setup.hs, it'll be one of the simple ones that only depends -- on Cabal and base. SetupNonCustomExternalLib -> - Just [ Dependency cabalPkgname cabalConstraint - , Dependency basePkgname anyVersion ] + Just [ Dependency cabalPkgname cabalConstraint (Set.singleton LMainLibName) + , Dependency basePkgname anyVersion (Set.singleton LMainLibName)] where cabalConstraint = orLaterVersion (PD.specVersion pkg) @@ -3135,7 +3187,7 @@ usePackageDB = elabSetupPackageDBStack, usePackageIndex = Nothing, useDependencies = [ (uid, srcid) - | ConfiguredId srcid (Just CLibName) uid + | ConfiguredId srcid (Just (CLibName LMainLibName)) uid <- elabSetupDependencies elab ], useDependenciesExclusive = True, useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps, @@ -3168,13 +3220,20 @@ -> CompilerId -> InstalledPackageId -> InstallDirs.InstallDirs FilePath -storePackageInstallDirs StoreDirLayout{ storePackageDirectory - , storeDirectory } - compid ipkgid = +storePackageInstallDirs storeDirLayout compid ipkgid = + storePackageInstallDirs' storeDirLayout compid $ newSimpleUnitId ipkgid + +storePackageInstallDirs' :: StoreDirLayout + -> CompilerId + -> UnitId + -> InstallDirs.InstallDirs FilePath +storePackageInstallDirs' StoreDirLayout{ storePackageDirectory + , storeDirectory } + compid unitid = InstallDirs.InstallDirs {..} where store = storeDirectory compid - prefix = storePackageDirectory compid (newSimpleUnitId ipkgid) + prefix = storePackageDirectory compid unitid bindir = prefix "bin" libdir = prefix "lib" libsubdir = "" @@ -3258,6 +3317,7 @@ configStaticLib = toFlag elabStaticLib configDynExe = toFlag elabDynExe + configFullyStaticExe = toFlag elabFullyStaticExe configGHCiLib = toFlag elabGHCiLib configProfExe = mempty configProfLib = toFlag elabProfLib @@ -3294,14 +3354,16 @@ -- NB: This does NOT use InstallPlan.depends, which includes executable -- dependencies which should NOT be fed in here (also you don't have -- enough info anyway) - configDependencies = [ (case mb_cn of - -- Special case for internal libraries - Just (CSubLibName uqn) - | packageId elab == srcid - -> mkPackageName (unUnqualComponentName uqn) - _ -> packageName srcid, - cid) - | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab ] + configDependencies = [ GivenComponent + (packageName srcid) + ln + cid + | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab + , let ln = case mb_cn + of Just (CLibName lname) -> lname + Just _ -> error "non-library dependency" + Nothing -> LMainLibName + ] configConstraints = case elabPkgOrComp of ElabPackage _ -> @@ -3328,6 +3390,9 @@ configUserInstall = mempty -- don't rely on defaults configPrograms_ = mempty -- never use, shouldn't exist configUseResponseFiles = mempty + -- TODO set to true when the solver can prevent private-library-deps by itself + -- (issue #6039) + configAllowDependingOnPrivateLibs = mempty setupHsConfigureArgs :: ElaboratedConfiguredPackage -> [String] @@ -3371,14 +3436,16 @@ -> Verbosity -> FilePath -> Cabal.TestFlags -setupHsTestFlags _ _ verbosity builddir = Cabal.TestFlags +setupHsTestFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.TestFlags { testDistPref = toFlag builddir , testVerbosity = toFlag verbosity - , testMachineLog = mempty - , testHumanLog = mempty - , testShowDetails = toFlag Cabal.Always - , testKeepTix = mempty - , testOptions = mempty + , testMachineLog = maybe mempty toFlag elabTestMachineLog + , testHumanLog = maybe mempty toFlag elabTestHumanLog + , testShowDetails = maybe (Flag Cabal.Always) toFlag elabTestShowDetails + , testKeepTix = toFlag elabTestKeepTix + , testWrapper = maybe mempty toFlag elabTestWrapper + , testFailWhenNoTestSuites = toFlag elabTestFailWhenNoTestSuites + , testOptions = elabTestTestOptions } setupHsTestArgs :: ElaboratedConfiguredPackage -> [String] @@ -3608,6 +3675,7 @@ pkgHashVanillaLib = elabVanillaLib, pkgHashSharedLib = elabSharedLib, pkgHashDynExe = elabDynExe, + pkgHashFullyStaticExe = elabFullyStaticExe, pkgHashGHCiLib = elabGHCiLib, pkgHashProfLib = elabProfLib, pkgHashProfExe = elabProfExe, diff --git a/Distribution/Client/ProjectPlanning/Types.hs b/Distribution/Client/ProjectPlanning/Types.hs --- a/Distribution/Client/ProjectPlanning/Types.hs +++ b/Distribution/Client/ProjectPlanning/Types.hs @@ -75,12 +75,12 @@ import Distribution.Backpack import Distribution.Backpack.ModuleShape +import Distribution.Pretty import Distribution.Verbosity -import Distribution.Text import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.PkgconfigVersion import Distribution.Types.PackageDescription (PackageDescription(..)) import Distribution.Package - hiding (InstalledPackageId, installedPackageId) import Distribution.System import qualified Distribution.PackageDescription as Cabal import Distribution.InstalledPackageInfo (InstalledPackageInfo) @@ -89,10 +89,11 @@ import qualified Distribution.Simple.BuildTarget as Cabal import Distribution.Simple.Program import Distribution.ModuleName (ModuleName) -import Distribution.Simple.LocalBuildInfo (ComponentName(..)) +import Distribution.Simple.LocalBuildInfo + ( ComponentName(..), LibraryName(..) ) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.InstallDirs (PathTemplate) -import Distribution.Simple.Setup (HaddockTarget) +import Distribution.Simple.Setup (HaddockTarget, TestShowDetails) import Distribution.Version import qualified Distribution.Solver.Types.ComponentDeps as CD @@ -132,8 +133,8 @@ -- | User-friendly display string for an 'ElaboratedPlanPackage'. elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String elabPlanPackageName verbosity (PreExisting ipkg) - | verbosity <= normal = display (packageName ipkg) - | otherwise = display (installedUnitId ipkg) + | verbosity <= normal = prettyShow (packageName ipkg) + | otherwise = prettyShow (installedUnitId ipkg) elabPlanPackageName verbosity (Configured elab) = elabConfiguredName verbosity elab elabPlanPackageName verbosity (Installed elab) @@ -247,6 +248,7 @@ elabSharedLib :: Bool, elabStaticLib :: Bool, elabDynExe :: Bool, + elabFullyStaticExe :: Bool, elabGHCiLib :: Bool, elabProfLib :: Bool, elabProfExe :: Bool, @@ -287,6 +289,14 @@ elabHaddockHscolourCss :: Maybe FilePath, elabHaddockContents :: Maybe PathTemplate, + elabTestMachineLog :: Maybe PathTemplate, + elabTestHumanLog :: Maybe PathTemplate, + elabTestShowDetails :: Maybe TestShowDetails, + elabTestKeepTix :: Bool, + elabTestWrapper :: Maybe FilePath, + elabTestFailWhenNoTestSuites :: Bool, + elabTestTestOptions :: [PathTemplate], + -- Setup.hs related things: -- | One of four modes for how we build and interact with the Setup.hs @@ -391,8 +401,7 @@ -- single file is_lib_target (ComponentTarget cn WholeComponent) = is_lib cn is_lib_target _ = False - is_lib CLibName = True - is_lib (CSubLibName _) = True + is_lib (CLibName _) = True is_lib _ = False -- | Construct the environment needed for the data files to work. @@ -463,7 +472,7 @@ elabComponentName :: ElaboratedConfiguredPackage -> Maybe ComponentName elabComponentName elab = case elabPkgOrComp elab of - ElabPackage _ -> Just CLibName -- there could be more, but default this + ElabPackage _ -> Just $ CLibName LMainLibName -- there could be more, but default this ElabComponent comp -> compComponentName comp -- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'. @@ -475,11 +484,11 @@ ElabComponent comp -> case compComponentName comp of Nothing -> "setup from " - Just CLibName -> "" - Just cname -> display cname ++ " from ") - ++ display (packageId elab) + Just (CLibName LMainLibName) -> "" + Just cname -> prettyShow cname ++ " from ") + ++ prettyShow (packageId elab) | otherwise - = display (elabUnitId elab) + = prettyShow (elabUnitId elab) elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams elabDistDirParams shared elab = DistDirParams { @@ -565,7 +574,7 @@ -- they are, need to do this differently ElabComponent _ -> [] -elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe Version)] +elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)] elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } = pkgPkgConfigDependencies pkg elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } @@ -635,10 +644,16 @@ -- internal executables). compExeDependencies :: [ConfiguredId], -- | The @pkg-config@ dependencies of the component - compPkgConfigDependencies :: [(PkgconfigName, Maybe Version)], + compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)], -- | The paths all our executable dependencies will be installed -- to once they are installed. compExeDependencyPaths :: [(ConfiguredId, FilePath)], + -- | The UnitIds of the libraries (identifying elaborated packages/ + -- components) that must be built before this project. This + -- is used purely for ordering purposes. It can contain both + -- references to definite and indefinite packages; an indefinite + -- UnitId indicates that we must typecheck that indefinite package + -- before we can build this one. compOrderLibDependencies :: [UnitId] } deriving (Eq, Show, Generic) @@ -683,7 +698,7 @@ -- because Cabal library does not track per-component -- pkg-config depends; it always does them all at once. -- - pkgPkgConfigDependencies :: [(PkgconfigName, Maybe Version)], + pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)], -- | Which optional stanzas (ie testsuites, benchmarks) will actually -- be enabled during the package configure step. @@ -755,7 +770,7 @@ FileTarget fname -> Cabal.BuildTargetFile cname fname showTestComponentTarget :: PackageId -> ComponentTarget -> Maybe String -showTestComponentTarget _ (ComponentTarget (CTestName n) _) = Just $ display n +showTestComponentTarget _ (ComponentTarget (CTestName n) _) = Just $ prettyShow n showTestComponentTarget _ _ = Nothing isTestComponentTarget :: ComponentTarget -> Bool @@ -763,7 +778,7 @@ isTestComponentTarget _ = False showBenchComponentTarget :: PackageId -> ComponentTarget -> Maybe String -showBenchComponentTarget _ (ComponentTarget (CBenchName n) _) = Just $ display n +showBenchComponentTarget _ (ComponentTarget (CBenchName n) _) = Just $ prettyShow n showBenchComponentTarget _ _ = Nothing isBenchComponentTarget :: ComponentTarget -> Bool @@ -779,8 +794,8 @@ isExeComponentTarget _ = False isSubLibComponentTarget :: ComponentTarget -> Bool -isSubLibComponentTarget (ComponentTarget (CSubLibName _) _) = True -isSubLibComponentTarget _ = False +isSubLibComponentTarget (ComponentTarget (CLibName (LSubLibName _)) _) = True +isSubLibComponentTarget _ = False componentOptionalStanza :: CD.Component -> Maybe OptionalStanza componentOptionalStanza (CD.ComponentTest _) = Just TestStanzas diff --git a/Distribution/Client/Run.hs b/Distribution/Client/Run.hs --- a/Distribution/Client/Run.hs +++ b/Distribution/Client/Run.hs @@ -35,7 +35,7 @@ addLibraryPath) import Distribution.System (Platform (..)) import Distribution.Verbosity (Verbosity) -import Distribution.Text (display) +import Distribution.Deprecated.Text (display) import qualified Distribution.Simple.GHCJS as GHCJS diff --git a/Distribution/Client/Sandbox.hs b/Distribution/Client/Sandbox.hs --- a/Distribution/Client/Sandbox.hs +++ b/Distribution/Client/Sandbox.hs @@ -91,6 +91,7 @@ import Distribution.Simple.PreProcess ( knownSuffixHandlers ) import Distribution.Simple.Program ( ProgramDb ) import Distribution.Simple.Setup ( Flag(..), HaddockFlags(..) + , emptyTestFlags , fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.SrcDist ( prepareTree ) import Distribution.Simple.Utils ( die', debug, notice, info, warn @@ -99,7 +100,7 @@ , createDirectoryIfMissingVerbose ) import Distribution.Package ( Package(..) ) import Distribution.System ( Platform ) -import Distribution.Text ( display ) +import Distribution.Deprecated.Text ( display ) import Distribution.Verbosity ( Verbosity ) import Distribution.Compat.Environment ( lookupEnv, setEnv ) import Distribution.Client.Compat.FilePerms ( setFileHidden ) @@ -684,7 +685,7 @@ ,comp, platform, progdb ,UseSandbox sandboxDir, Just sandboxPkgInfo ,globalFlags, configFlags, configExFlags, installFlags - ,haddockFlags) + ,haddockFlags, emptyTestFlags) -- This can actually be replaced by a call to 'install', but we use a -- lower-level API because of layer separation reasons. Additionally, we diff --git a/Distribution/Client/Sandbox/PackageEnvironment.hs b/Distribution/Client/Sandbox/PackageEnvironment.hs --- a/Distribution/Client/Sandbox/PackageEnvironment.hs +++ b/Distribution/Client/Sandbox/PackageEnvironment.hs @@ -52,7 +52,7 @@ , fromFlagOrDefault, toFlag, flagToMaybe ) import Distribution.Simple.Utils ( die', info, notice, warn, debug ) import Distribution.Solver.Types.ConstraintSource -import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..) +import Distribution.Deprecated.ParseUtils ( FieldDescr(..), ParseResult(..) , commaListField, commaNewLineListField , liftField, lineNo, locatedErrorMsg , parseFilePathQ, readFields @@ -73,9 +73,9 @@ import Text.PrettyPrint ( ($+$) ) import qualified Text.PrettyPrint as Disp -import qualified Distribution.Compat.ReadP as Parse -import qualified Distribution.ParseUtils as ParseUtils ( Field(..) ) -import qualified Distribution.Text as Text +import qualified Distribution.Deprecated.ReadP as Parse +import qualified Distribution.Deprecated.ParseUtils as ParseUtils ( Field(..) ) +import qualified Distribution.Deprecated.Text as Text import GHC.Generics ( Generic ) diff --git a/Distribution/Client/Sandbox/Timestamp.hs b/Distribution/Client/Sandbox/Timestamp.hs --- a/Distribution/Client/Sandbox/Timestamp.hs +++ b/Distribution/Client/Sandbox/Timestamp.hs @@ -31,7 +31,7 @@ import Distribution.Compiler (CompilerId) import Distribution.Simple.Utils (debug, die', warn) import Distribution.System (Platform) -import Distribution.Text (display) +import Distribution.Deprecated.Text (display) import Distribution.Verbosity (Verbosity) import Distribution.Client.SrcDist (allPackageSourceFiles) diff --git a/Distribution/Client/Security/HTTP.hs b/Distribution/Client/Security/HTTP.hs --- a/Distribution/Client/Security/HTTP.hs +++ b/Distribution/Client/Security/HTTP.hs @@ -153,7 +153,7 @@ instance Pretty UnexpectedResponse where pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code - ++ "for " ++ show uri + ++ " for " ++ show uri #if MIN_VERSION_base(4,8,0) deriving instance Show UnexpectedResponse diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs --- a/Distribution/Client/Setup.hs +++ b/Distribution/Client/Setup.hs @@ -18,14 +18,15 @@ module Distribution.Client.Setup ( globalCommand, GlobalFlags(..), defaultGlobalFlags , RepoContext(..), withRepoContext - , configureCommand, ConfigFlags(..), filterConfigureFlags + , configureCommand, ConfigFlags(..), configureOptions, filterConfigureFlags , configPackageDB', configCompilerAux' , configureExCommand, ConfigExFlags(..), defaultConfigExFlags , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) - , replCommand, testCommand, benchmarkCommand + , filterTestFlags + , replCommand, testCommand, benchmarkCommand, testOptions , configureExOptions, reconfigureCommand , installCommand, InstallFlags(..), installOptions, defaultInstallFlags - , filterHaddockArgs, filterHaddockFlags + , filterHaddockArgs, filterHaddockFlags, haddockOptions , defaultSolver, defaultMaxBackjumps , listCommand, ListFlags(..) , updateCommand, UpdateFlags(..), defaultUpdateFlags @@ -42,8 +43,8 @@ , uploadCommand, UploadFlags(..), IsCandidate(..) , reportCommand, ReportFlags(..) , runCommand - , initCommand, IT.InitFlags(..) - , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) + , initCommand, initOptions, IT.InitFlags(..) + , sdistCommand, SDistFlags(..) , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..) , actAsSetupCommand, ActAsSetupFlags(..) , sandboxCommand, defaultSandboxLocation, SandboxFlags(..) @@ -68,6 +69,8 @@ import Prelude () import Distribution.Client.Compat.Prelude hiding (get) +import Distribution.Deprecated.ReadP (readP_to_E) + import Distribution.Client.Types ( Username(..), Password(..), RemoteRepo(..) , AllowNewer(..), AllowOlder(..), RelaxDeps(..) @@ -98,7 +101,7 @@ import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Setup ( ConfigFlags(..), BuildFlags(..), ReplFlags - , TestFlags(..), BenchmarkFlags(..) + , TestFlags, BenchmarkFlags(..) , SDistFlags(..), HaddockFlags(..) , CleanFlags(..), DoctestFlags(..) , CopyFlags(..), RegisterFlags(..) @@ -113,18 +116,24 @@ import Distribution.Version ( Version, mkVersion, nullVersion, anyVersion, thisVersion ) import Distribution.Package - ( PackageIdentifier, PackageName, packageName, packageVersion ) + ( PackageName, PackageIdentifier, packageName, packageVersion ) import Distribution.Types.Dependency +import Distribution.Types.GivenComponent + ( GivenComponent(..) ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint(..) ) +import Distribution.Types.UnqualComponentName + ( unqualComponentNameToPackageName ) import Distribution.PackageDescription - ( BuildType(..), RepoKind(..) ) + ( BuildType(..), RepoKind(..), LibraryName(..) ) import Distribution.System ( Platform ) -import Distribution.Text +import Distribution.Deprecated.Text ( Text(..), display ) import Distribution.ReadE - ( ReadE(..), readP_to_E, succeedReadE ) -import qualified Distribution.Compat.ReadP as Parse + ( ReadE(..), succeedReadE ) +import qualified Distribution.Deprecated.ReadP as Parse ( ReadP, char, munch1, pfail, sepBy1, (+++) ) -import Distribution.ParseUtils +import Distribution.Deprecated.ParseUtils ( readPToMaybe ) import Distribution.Verbosity ( Verbosity, lessVerbose, normal, verboseNoFlags, verboseNoTimestamp ) @@ -137,6 +146,7 @@ import Data.List ( deleteFirstsBy ) +import qualified Data.Set as Set import System.FilePath ( () ) import Network.URI @@ -172,7 +182,6 @@ , "get" , "init" , "configure" - , "reconfigure" , "build" , "clean" , "run" @@ -186,12 +195,8 @@ , "freeze" , "gen-bounds" , "outdated" - , "doctest" , "haddock" , "hscolour" - , "copy" - , "register" - , "sandbox" , "exec" , "new-build" , "new-configure" @@ -247,10 +252,6 @@ addCmd n = case lookup n cmdDescs of Nothing -> "" Just d -> " " ++ align n ++ " " ++ d - addCmdCustom n d = case lookup n cmdDescs of -- make sure that the - -- command still exists. - Nothing -> "" - Just _ -> " " ++ align n ++ " " ++ d in "Commands:\n" ++ unlines ( @@ -285,17 +286,9 @@ , addCmd "freeze" , addCmd "gen-bounds" , addCmd "outdated" - , addCmd "doctest" , addCmd "haddock" , addCmd "hscolour" - , addCmd "copy" - , addCmd "register" - , addCmd "reconfigure" - , par - , startGroup "sandbox" - , addCmd "sandbox" , addCmd "exec" - , addCmdCustom "repl" "Open interpreter with access to sandbox packages." , par , startGroup "new-style projects (beta)" , addCmd "new-build" @@ -498,7 +491,7 @@ filterConfigureFlags flags cabalLibVersion -- NB: we expect the latest version to be the most common case, -- so test it first. - | cabalLibVersion >= mkVersion [2,1,0] = flags_latest + | cabalLibVersion >= mkVersion [2,5,0] = flags_latest -- The naming convention is that flags_version gives flags with -- all flags *introduced* in version eliminated. -- It is NOT the latest version of Cabal library that @@ -513,17 +506,39 @@ | cabalLibVersion < mkVersion [1,19,2] = flags_1_19_2 | cabalLibVersion < mkVersion [1,21,1] = flags_1_21_1 | cabalLibVersion < mkVersion [1,22,0] = flags_1_22_0 + | cabalLibVersion < mkVersion [1,22,1] = flags_1_22_1 | cabalLibVersion < mkVersion [1,23,0] = flags_1_23_0 | cabalLibVersion < mkVersion [1,25,0] = flags_1_25_0 | cabalLibVersion < mkVersion [2,1,0] = flags_2_1_0 - | otherwise = flags_latest + | cabalLibVersion < mkVersion [2,5,0] = flags_2_5_0 + | otherwise = error "the impossible just happened" -- see first guard where flags_latest = flags { -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'. + -- Note: this is not in the wrong place. configConstraints gets + -- repopulated in flags_1_19_1 but it needs to be set to empty for + -- newer versions first. configConstraints = [] } - flags_2_1_0 = flags_latest { + flags_2_5_0 = flags_latest { + -- Cabal < 2.5 does not understand --dependency=pkg:component=cid + -- (public sublibraries), so we convert it to the legacy + -- --dependency=pkg_or_internal_compoent=cid + configDependencies = + let convertToLegacyInternalDep (GivenComponent _ (LSubLibName cn) cid) = + Just $ GivenComponent + (unqualComponentNameToPackageName cn) + LMainLibName + cid + convertToLegacyInternalDep (GivenComponent pn LMainLibName cid) = + Just $ GivenComponent pn LMainLibName cid + in catMaybes $ convertToLegacyInternalDep <$> configDependencies flags + -- Cabal < 2.5 doesn't know about '--enable/disable-executable-static'. + , configFullyStaticExe = NoFlag + } + + flags_2_1_0 = flags_2_5_0 { -- Cabal < 2.1 doesn't know about -v +timestamp modifier configVerbosity = fmap verboseNoTimestamp (configVerbosity flags_latest) -- Cabal < 2.1 doesn't know about ---static @@ -558,6 +573,12 @@ , configProfLib = Flag tryLibProfiling } + -- Cabal == 1.22.0.* had a discontinuity (see #5946 or e9a8d48a3adce34d) + -- due to temporary amnesia of the --*-executable-profiling flags + flags_1_22_1 = flags_1_23_0 { configDebugInfo = NoFlag + , configProfExe = NoFlag + } + -- Cabal < 1.22 doesn't know about '--disable-debug-info'. flags_1_22_0 = flags_1_23_0 { configDebugInfo = NoFlag } @@ -615,7 +636,7 @@ data ConfigExFlags = ConfigExFlags { configCabalVersion :: Flag Version, configExConstraints :: [(UserConstraint, ConstraintSource)], - configPreferences :: [Dependency], + configPreferences :: [PackageVersionConstraint], configSolver :: Flag PreSolver, configAllowNewer :: Maybe AllowNewer, configAllowOlder :: Maybe AllowOlder, @@ -810,6 +831,37 @@ (<>) = gmappend -- ------------------------------------------------------------ +-- * Test flags +-- ------------------------------------------------------------ + +-- | Given some 'TestFlags' for the version of Cabal that +-- cabal-install was built with, and a target older 'Version' of +-- Cabal that we want to pass these flags to, convert the +-- flags into a form that will be accepted by the older +-- Setup script. Generally speaking, this just means filtering +-- out flags that the old Cabal library doesn't understand, but +-- in some cases it may also mean "emulating" a feature using +-- some more legacy flags. +filterTestFlags :: TestFlags -> Version -> TestFlags +filterTestFlags flags cabalLibVersion + -- NB: we expect the latest version to be the most common case, + -- so test it first. + | cabalLibVersion >= mkVersion [3,0,0] = flags_latest + -- The naming convention is that flags_version gives flags with + -- all flags *introduced* in version eliminated. + -- It is NOT the latest version of Cabal library that + -- these flags work for; version of introduction is a more + -- natural metric. + | cabalLibVersion < mkVersion [3,0,0] = flags_3_0_0 + | otherwise = error "the impossible just happened" -- see first guard + where + flags_latest = flags + flags_3_0_0 = flags_latest { + -- Cabal < 3.0 doesn't know about --test-wrapper + Cabal.testWrapper = NoFlag + } + +-- ------------------------------------------------------------ -- * Repl command -- ------------------------------------------------------------ @@ -945,10 +997,12 @@ fetchMaxBackjumps :: Flag Int, fetchReorderGoals :: Flag ReorderGoals, fetchCountConflicts :: Flag CountConflicts, + fetchMinimizeConflictSet :: Flag MinimizeConflictSet, fetchIndependentGoals :: Flag IndependentGoals, fetchShadowPkgs :: Flag ShadowPkgs, fetchStrongFlags :: Flag StrongFlags, fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls, + fetchOnlyConstrained :: Flag OnlyConstrained, fetchTests :: Flag Bool, fetchBenchmarks :: Flag Bool, fetchVerbosity :: Flag Verbosity @@ -963,10 +1017,12 @@ fetchMaxBackjumps = Flag defaultMaxBackjumps, fetchReorderGoals = Flag (ReorderGoals False), fetchCountConflicts = Flag (CountConflicts True), + fetchMinimizeConflictSet = Flag (MinimizeConflictSet False), fetchIndependentGoals = Flag (IndependentGoals False), fetchShadowPkgs = Flag (ShadowPkgs False), fetchStrongFlags = Flag (StrongFlags False), fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False), + fetchOnlyConstrained = Flag OnlyConstrainedNone, fetchTests = toFlag False, fetchBenchmarks = toFlag False, fetchVerbosity = toFlag normal @@ -1023,10 +1079,12 @@ fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v }) fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v }) fetchCountConflicts (\v flags -> flags { fetchCountConflicts = v }) + fetchMinimizeConflictSet (\v flags -> flags { fetchMinimizeConflictSet = v }) fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v }) fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v }) fetchStrongFlags (\v flags -> flags { fetchStrongFlags = v }) fetchAllowBootLibInstalls (\v flags -> flags { fetchAllowBootLibInstalls = v }) + fetchOnlyConstrained (\v flags -> flags { fetchOnlyConstrained = v }) } @@ -1042,10 +1100,12 @@ freezeMaxBackjumps :: Flag Int, freezeReorderGoals :: Flag ReorderGoals, freezeCountConflicts :: Flag CountConflicts, + freezeMinimizeConflictSet :: Flag MinimizeConflictSet, freezeIndependentGoals :: Flag IndependentGoals, freezeShadowPkgs :: Flag ShadowPkgs, freezeStrongFlags :: Flag StrongFlags, freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls, + freezeOnlyConstrained :: Flag OnlyConstrained, freezeVerbosity :: Flag Verbosity } @@ -1058,10 +1118,12 @@ freezeMaxBackjumps = Flag defaultMaxBackjumps, freezeReorderGoals = Flag (ReorderGoals False), freezeCountConflicts = Flag (CountConflicts True), + freezeMinimizeConflictSet = Flag (MinimizeConflictSet False), freezeIndependentGoals = Flag (IndependentGoals False), freezeShadowPkgs = Flag (ShadowPkgs False), freezeStrongFlags = Flag (StrongFlags False), freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False), + freezeOnlyConstrained = Flag OnlyConstrainedNone, freezeVerbosity = toFlag normal } @@ -1109,10 +1171,12 @@ freezeMaxBackjumps (\v flags -> flags { freezeMaxBackjumps = v }) freezeReorderGoals (\v flags -> flags { freezeReorderGoals = v }) freezeCountConflicts (\v flags -> flags { freezeCountConflicts = v }) + freezeMinimizeConflictSet (\v flags -> flags { freezeMinimizeConflictSet = v }) freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v }) freezeShadowPkgs (\v flags -> flags { freezeShadowPkgs = v }) freezeStrongFlags (\v flags -> flags { freezeStrongFlags = v }) freezeAllowBootLibInstalls (\v flags -> flags { freezeAllowBootLibInstalls = v }) + freezeOnlyConstrained (\v flags -> flags { freezeOnlyConstrained = v }) } @@ -1201,7 +1265,7 @@ outdatedFreezeFile (\v flags -> flags { outdatedFreezeFile = v }) trueArg - ,option [] ["new-freeze-file", "v2-freeze-file"] + ,option [] ["v2-freeze-file", "new-freeze-file"] "Act on the new-style freeze file (default: cabal.project.freeze)" outdatedNewFreezeFile (\v flags -> flags { outdatedNewFreezeFile = v }) trueArg @@ -1303,13 +1367,13 @@ -- * Other commands -- ------------------------------------------------------------ -upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) upgradeCommand = configureCommand { commandName = "upgrade", commandSynopsis = "(command disabled, use install instead)", commandDescription = Nothing, commandUsage = usageFlagsOrPackages "upgrade", - commandDefaultFlags = (mempty, mempty, mempty, mempty), + commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty), commandOptions = commandOptions installCommand } @@ -1677,10 +1741,12 @@ installMaxBackjumps :: Flag Int, installReorderGoals :: Flag ReorderGoals, installCountConflicts :: Flag CountConflicts, + installMinimizeConflictSet :: Flag MinimizeConflictSet, installIndependentGoals :: Flag IndependentGoals, installShadowPkgs :: Flag ShadowPkgs, installStrongFlags :: Flag StrongFlags, installAllowBootLibInstalls :: Flag AllowBootLibInstalls, + installOnlyConstrained :: Flag OnlyConstrained, installReinstall :: Flag Bool, installAvoidReinstalls :: Flag AvoidReinstalls, installOverrideReinstall :: Flag Bool, @@ -1693,6 +1759,8 @@ installLogFile :: Flag PathTemplate, installBuildReports :: Flag ReportLevel, installReportPlanningFailure :: Flag Bool, + -- Note: symlink-bindir is no longer used by v2-install and can be removed + -- when removing v1 commands installSymlinkBinDir :: Flag FilePath, installPerComponent :: Flag Bool, installOneShot :: Flag Bool, @@ -1722,10 +1790,12 @@ installMaxBackjumps = Flag defaultMaxBackjumps, installReorderGoals = Flag (ReorderGoals False), installCountConflicts = Flag (CountConflicts True), + installMinimizeConflictSet = Flag (MinimizeConflictSet False), installIndependentGoals= Flag (IndependentGoals False), installShadowPkgs = Flag (ShadowPkgs False), installStrongFlags = Flag (StrongFlags False), installAllowBootLibInstalls = Flag (AllowBootLibInstalls False), + installOnlyConstrained = Flag OnlyConstrainedNone, installReinstall = Flag False, installAvoidReinstalls = Flag (AvoidReinstalls False), installOverrideReinstall = Flag False, @@ -1752,7 +1822,7 @@ "$arch-$os-$compiler" "index.html") defaultMaxBackjumps :: Int -defaultMaxBackjumps = 2000 +defaultMaxBackjumps = 4000 defaultSolver :: PreSolver defaultSolver = AlwaysModular @@ -1760,7 +1830,7 @@ allSolvers :: String allSolvers = intercalate ", " (map display ([minBound .. maxBound] :: [PreSolver])) -installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) installCommand = CommandUI { commandName = "install", commandSynopsis = "Install packages.", @@ -1813,7 +1883,7 @@ ++ " " ++ (map (const ' ') pname) ++ " " ++ " Change installation destination\n", - commandDefaultFlags = (mempty, mempty, mempty, mempty), + commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty), commandOptions = \showOrParseArgs -> liftOptions get1 set1 -- Note: [Hidden Flags] @@ -1831,12 +1901,14 @@ . optionName) $ installOptions showOrParseArgs) ++ liftOptions get4 set4 (haddockOptions showOrParseArgs) + ++ liftOptions get5 set5 (testOptions showOrParseArgs) } where - get1 (a,_,_,_) = a; set1 a (_,b,c,d) = (a,b,c,d) - get2 (_,b,_,_) = b; set2 b (a,_,c,d) = (a,b,c,d) - get3 (_,_,c,_) = c; set3 c (a,b,_,d) = (a,b,c,d) - get4 (_,_,_,d) = d; set4 d (a,b,c,_) = (a,b,c,d) + get1 (a,_,_,_,_) = a; set1 a (_,b,c,d,e) = (a,b,c,d,e) + get2 (_,b,_,_,_) = b; set2 b (a,_,c,d,e) = (a,b,c,d,e) + get3 (_,_,c,_,_) = c; set3 c (a,b,_,d,e) = (a,b,c,d,e) + get4 (_,_,_,d,_) = d; set4 d (a,b,c,_,e) = (a,b,c,d,e) + get5 (_,_,_,_,e) = e; set5 e (a,b,c,d,_) = (a,b,c,d,e) haddockCommand :: CommandUI HaddockFlags haddockCommand = Cabal.haddockCommand @@ -1880,13 +1952,28 @@ ,"hyperlink-source", "quickjump", "hscolour-css" ,"contents-location", "for-hackage"] ] + +testOptions :: ShowOrParseArgs -> [OptionField TestFlags] +testOptions showOrParseArgs + = [ opt { optionName = prefixTest name, + optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixTest lflags)) descr + | descr <- optionDescr opt] } + | opt <- commandOptions Cabal.testCommand showOrParseArgs + , let name = optionName opt + , name `elem` ["log", "machine-log", "show-details", "keep-tix-files" + ,"fail-when-no-test-suites", "test-options", "test-option" + ,"test-wrapper"] + ] where - fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a - fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w - fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w - fmapOptFlags modify (ChoiceOpt xs) = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs] - fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w + prefixTest name | "test-" `isPrefixOf` name = name + | otherwise = "test-" ++ name +fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a +fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w +fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w +fmapOptFlags modify (ChoiceOpt xs) = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs] +fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w + installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] installOptions showOrParseArgs = [ option "" ["documentation"] @@ -1916,10 +2003,12 @@ installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v }) installReorderGoals (\v flags -> flags { installReorderGoals = v }) installCountConflicts (\v flags -> flags { installCountConflicts = v }) + installMinimizeConflictSet (\v flags -> flags { installMinimizeConflictSet = v }) installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) installStrongFlags (\v flags -> flags { installStrongFlags = v }) - installAllowBootLibInstalls (\v flags -> flags { installAllowBootLibInstalls = v }) ++ + installAllowBootLibInstalls (\v flags -> flags { installAllowBootLibInstalls = v }) + installOnlyConstrained (\v flags -> flags { installOnlyConstrained = v }) ++ [ option [] ["reinstall"] "Install even if it means installing the same version again." @@ -2141,240 +2230,231 @@ initCommand :: CommandUI IT.InitFlags initCommand = CommandUI { commandName = "init", - commandSynopsis = "Create a new .cabal package file (interactively).", + commandSynopsis = "Create a new .cabal package file.", commandDescription = Just $ \_ -> wrapText $ - "Cabalise a project by creating a .cabal, Setup.hs, and " - ++ "optionally a LICENSE file.\n" + "Create a .cabal, Setup.hs, and optionally a LICENSE file.\n" ++ "\n" - ++ "Calling init with no arguments (recommended) uses an " - ++ "interactive mode, which will try to guess as much as " - ++ "possible and prompt you for the rest. Command-line " - ++ "arguments are provided for scripting purposes. " - ++ "If you don't want interactive mode, be sure to pass " - ++ "the -n flag.\n", + ++ "Calling init with no arguments creates an executable, " + ++ "guessing as many options as possible. The interactive " + ++ "mode can be invoked by the -i/--interactive flag, which " + ++ "will try to guess as much as possible and prompt you for " + ++ "the rest. You can change init to always be interactive by " + ++ "setting the interactive flag in your configuration file. " + ++ "Command-line arguments are provided for scripting purposes.\n", commandNotes = Nothing, commandUsage = \pname -> "Usage: " ++ pname ++ " init [FLAGS]\n", commandDefaultFlags = defaultInitFlags, - commandOptions = \_ -> - [ option ['n'] ["non-interactive"] - "Non-interactive mode." - IT.nonInteractive (\v flags -> flags { IT.nonInteractive = v }) - trueArg + commandOptions = initOptions + } - , option ['q'] ["quiet"] - "Do not generate log messages to stdout." - IT.quiet (\v flags -> flags { IT.quiet = v }) - trueArg +initOptions :: ShowOrParseArgs -> [OptionField IT.InitFlags] +initOptions _ = + [ option ['i'] ["interactive"] + "interactive mode." + IT.interactive (\v flags -> flags { IT.interactive = v }) + (boolOpt' (['i'], ["interactive"]) (['n'], ["non-interactive"])) - , option [] ["no-comments"] - "Do not generate explanatory comments in the .cabal file." - IT.noComments (\v flags -> flags { IT.noComments = v }) - trueArg + , option ['q'] ["quiet"] + "Do not generate log messages to stdout." + IT.quiet (\v flags -> flags { IT.quiet = v }) + trueArg - , option ['m'] ["minimal"] - "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments." - IT.minimal (\v flags -> flags { IT.minimal = v }) - trueArg + , option [] ["no-comments"] + "Do not generate explanatory comments in the .cabal file." + IT.noComments (\v flags -> flags { IT.noComments = v }) + trueArg - , option [] ["overwrite"] - "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning." - IT.overwrite (\v flags -> flags { IT.overwrite = v }) - trueArg + , option ['m'] ["minimal"] + "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments." + IT.minimal (\v flags -> flags { IT.minimal = v }) + trueArg - , option [] ["package-dir", "packagedir"] - "Root directory of the package (default = current directory)." - IT.packageDir (\v flags -> flags { IT.packageDir = v }) - (reqArgFlag "DIRECTORY") + , option [] ["overwrite"] + "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning." + IT.overwrite (\v flags -> flags { IT.overwrite = v }) + trueArg - , option ['p'] ["package-name"] - "Name of the Cabal package to create." - IT.packageName (\v flags -> flags { IT.packageName = v }) - (reqArg "PACKAGE" (readP_to_E ("Cannot parse package name: "++) - (toFlag `fmap` parse)) - (flagToList . fmap display)) + , option [] ["package-dir", "packagedir"] + "Root directory of the package (default = current directory)." + IT.packageDir (\v flags -> flags { IT.packageDir = v }) + (reqArgFlag "DIRECTORY") - , option [] ["version"] - "Initial version of the package." - IT.version (\v flags -> flags { IT.version = v }) - (reqArg "VERSION" (readP_to_E ("Cannot parse package version: "++) - (toFlag `fmap` parse)) - (flagToList . fmap display)) + , option ['p'] ["package-name"] + "Name of the Cabal package to create." + IT.packageName (\v flags -> flags { IT.packageName = v }) + (reqArg "PACKAGE" (readP_to_E ("Cannot parse package name: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) - , option [] ["cabal-version"] - "Version of the Cabal specification." - IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v }) - (reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal specification version: "++) - (toFlag `fmap` parse)) - (flagToList . fmap display)) + , option [] ["version"] + "Initial version of the package." + IT.version (\v flags -> flags { IT.version = v }) + (reqArg "VERSION" (readP_to_E ("Cannot parse package version: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) - , option ['l'] ["license"] - "Project license." - IT.license (\v flags -> flags { IT.license = v }) - (reqArg "LICENSE" (readP_to_E ("Cannot parse license: "++) - (toFlag `fmap` parse)) - (flagToList . fmap display)) + , option [] ["cabal-version"] + "Version of the Cabal specification." + IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v }) + (reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal specification version: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) - , option ['a'] ["author"] - "Name of the project's author." - IT.author (\v flags -> flags { IT.author = v }) - (reqArgFlag "NAME") + , option ['l'] ["license"] + "Project license." + IT.license (\v flags -> flags { IT.license = v }) + (reqArg "LICENSE" (readP_to_E ("Cannot parse license: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) - , option ['e'] ["email"] - "Email address of the maintainer." - IT.email (\v flags -> flags { IT.email = v }) - (reqArgFlag "EMAIL") + , option ['a'] ["author"] + "Name of the project's author." + IT.author (\v flags -> flags { IT.author = v }) + (reqArgFlag "NAME") - , option ['u'] ["homepage"] - "Project homepage and/or repository." - IT.homepage (\v flags -> flags { IT.homepage = v }) - (reqArgFlag "URL") + , option ['e'] ["email"] + "Email address of the maintainer." + IT.email (\v flags -> flags { IT.email = v }) + (reqArgFlag "EMAIL") - , option ['s'] ["synopsis"] - "Short project synopsis." - IT.synopsis (\v flags -> flags { IT.synopsis = v }) - (reqArgFlag "TEXT") + , option ['u'] ["homepage"] + "Project homepage and/or repository." + IT.homepage (\v flags -> flags { IT.homepage = v }) + (reqArgFlag "URL") - , option ['c'] ["category"] - "Project category." - IT.category (\v flags -> flags { IT.category = v }) - (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s)) - (flagToList . fmap (either id show))) + , option ['s'] ["synopsis"] + "Short project synopsis." + IT.synopsis (\v flags -> flags { IT.synopsis = v }) + (reqArgFlag "TEXT") - , option ['x'] ["extra-source-file"] - "Extra source file to be distributed with tarball." - IT.extraSrc (\v flags -> flags { IT.extraSrc = v }) - (reqArg' "FILE" (Just . (:[])) - (fromMaybe [])) + , option ['c'] ["category"] + "Project category." + IT.category (\v flags -> flags { IT.category = v }) + (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s)) + (flagToList . fmap (either id show))) - , option [] ["is-library"] - "Build a library." - IT.packageType (\v flags -> flags { IT.packageType = v }) - (noArg (Flag IT.Library)) + , option ['x'] ["extra-source-file"] + "Extra source file to be distributed with tarball." + IT.extraSrc (\v flags -> flags { IT.extraSrc = v }) + (reqArg' "FILE" (Just . (:[])) + (fromMaybe [])) - , option [] ["is-executable"] - "Build an executable." - IT.packageType - (\v flags -> flags { IT.packageType = v }) - (noArg (Flag IT.Executable)) + , option [] ["lib", "is-library"] + "Build a library." + IT.packageType (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.Library)) - , option [] ["is-libandexe"] - "Build a library and an executable." - IT.packageType - (\v flags -> flags { IT.packageType = v }) - (noArg (Flag IT.LibraryAndExecutable)) + , option [] ["exe", "is-executable"] + "Build an executable." + IT.packageType + (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.Executable)) - , option [] ["main-is"] - "Specify the main module." - IT.mainIs - (\v flags -> flags { IT.mainIs = v }) - (reqArgFlag "FILE") + , option [] ["libandexe", "is-libandexe"] + "Build a library and an executable." + IT.packageType + (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.LibraryAndExecutable)) - , option [] ["language"] - "Specify the default language." - IT.language - (\v flags -> flags { IT.language = v }) - (reqArg "LANGUAGE" (readP_to_E ("Cannot parse language: "++) - (toFlag `fmap` parse)) - (flagToList . fmap display)) + , option [] ["tests"] + "Generate a test suite for the library." + IT.initializeTestSuite + (\v flags -> flags { IT.initializeTestSuite = v }) + trueArg - , option ['o'] ["expose-module"] - "Export a module from the package." - IT.exposedModules - (\v flags -> flags { IT.exposedModules = v }) - (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++) - ((Just . (:[])) `fmap` parse)) - (maybe [] (fmap display))) + , option [] ["test-dir"] + "Directory containing tests." + IT.testDirs (\v flags -> flags { IT.testDirs = v }) + (reqArg' "DIR" (Just . (:[])) + (fromMaybe [])) - , option [] ["extension"] - "Use a LANGUAGE extension (in the other-extensions field)." - IT.otherExts - (\v flags -> flags { IT.otherExts = v }) - (reqArg "EXTENSION" (readP_to_E ("Cannot parse extension: "++) - ((Just . (:[])) `fmap` parse)) - (maybe [] (fmap display))) + , option [] ["simple"] + "Create a simple project with sensible defaults." + IT.simpleProject + (\v flags -> flags { IT.simpleProject = v }) + trueArg - , option ['d'] ["dependency"] - "Package dependency." - IT.dependencies (\v flags -> flags { IT.dependencies = v }) - (reqArg "PACKAGE" (readP_to_E ("Cannot parse dependency: "++) - ((Just . (:[])) `fmap` parse)) - (maybe [] (fmap display))) + , option [] ["main-is"] + "Specify the main module." + IT.mainIs + (\v flags -> flags { IT.mainIs = v }) + (reqArgFlag "FILE") - , option [] ["source-dir", "sourcedir"] - "Directory containing package source." - IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v }) - (reqArg' "DIR" (Just . (:[])) - (fromMaybe [])) + , option [] ["language"] + "Specify the default language." + IT.language + (\v flags -> flags { IT.language = v }) + (reqArg "LANGUAGE" (readP_to_E ("Cannot parse language: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) - , option [] ["build-tool"] - "Required external build tool." - IT.buildTools (\v flags -> flags { IT.buildTools = v }) - (reqArg' "TOOL" (Just . (:[])) - (fromMaybe [])) + , option ['o'] ["expose-module"] + "Export a module from the package." + IT.exposedModules + (\v flags -> flags { IT.exposedModules = v }) + (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++) + ((Just . (:[])) `fmap` parse)) + (maybe [] (fmap display))) - -- NB: this is a bit of a transitional hack and will likely be - -- removed again if `cabal init` is migrated to the v2-* command - -- framework - , option "w" ["with-compiler"] - "give the path to a particular compiler" - IT.initHcPath (\v flags -> flags { IT.initHcPath = v }) - (reqArgFlag "PATH") + , option [] ["extension"] + "Use a LANGUAGE extension (in the other-extensions field)." + IT.otherExts + (\v flags -> flags { IT.otherExts = v }) + (reqArg "EXTENSION" (readP_to_E ("Cannot parse extension: "++) + ((Just . (:[])) `fmap` parse)) + (maybe [] (fmap display))) - , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v }) - ] - } + , option ['d'] ["dependency"] + "Package dependency." + IT.dependencies (\v flags -> flags { IT.dependencies = v }) + (reqArg "PACKAGE" (readP_to_E ("Cannot parse dependency: "++) + ((Just . (:[])) `fmap` parse)) + (maybe [] (fmap display))) + , option [] ["application-dir"] + "Directory containing package application executable." + IT.applicationDirs (\v flags -> flags { IT.applicationDirs = v}) + (reqArg' "DIR" (Just . (:[])) + (fromMaybe [])) + + , option [] ["source-dir", "sourcedir"] + "Directory containing package library source." + IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v }) + (reqArg' "DIR" (Just . (:[])) + (fromMaybe [])) + + , option [] ["build-tool"] + "Required external build tool." + IT.buildTools (\v flags -> flags { IT.buildTools = v }) + (reqArg' "TOOL" (Just . (:[])) + (fromMaybe [])) + + -- NB: this is a bit of a transitional hack and will likely be + -- removed again if `cabal init` is migrated to the v2-* command + -- framework + , option "w" ["with-compiler"] + "give the path to a particular compiler" + IT.initHcPath (\v flags -> flags { IT.initHcPath = v }) + (reqArgFlag "PATH") + + , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v }) + ] + -- ------------------------------------------------------------ -- * SDist flags -- ------------------------------------------------------------ -- | Extra flags to @sdist@ beyond runghc Setup sdist -- -data SDistExFlags = SDistExFlags { - sDistFormat :: Flag ArchiveFormat - } - deriving (Show, Generic) - -data ArchiveFormat = TargzFormat | ZipFormat -- ... - deriving (Show, Eq) - -defaultSDistExFlags :: SDistExFlags -defaultSDistExFlags = SDistExFlags { - sDistFormat = Flag TargzFormat - } - -sdistCommand :: CommandUI (SDistFlags, SDistExFlags) +sdistCommand :: CommandUI SDistFlags sdistCommand = Cabal.sdistCommand { commandUsage = \pname -> "Usage: " ++ pname ++ " v1-sdist [FLAGS]\n", - commandDefaultFlags = (commandDefaultFlags Cabal.sdistCommand, defaultSDistExFlags), - commandOptions = \showOrParseArgs -> - liftOptions fst setFst (commandOptions Cabal.sdistCommand showOrParseArgs) - ++ liftOptions snd setSnd sdistExOptions + commandDefaultFlags = (commandDefaultFlags Cabal.sdistCommand) } - where - setFst a (_,b) = (a,b) - setSnd b (a,_) = (a,b) - sdistExOptions = - [option [] ["archive-format"] "archive-format" - sDistFormat (\v flags -> flags { sDistFormat = v }) - (choiceOpt - [ (Flag TargzFormat, ([], ["targz"]), - "Produce a '.tar.gz' format archive (default and required for uploading to hackage)") - , (Flag ZipFormat, ([], ["zip"]), - "Produce a '.zip' format archive") - ]) - ] -instance Monoid SDistExFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup SDistExFlags where - (<>) = gmappend - -- doctestCommand :: CommandUI DoctestFlags @@ -2723,6 +2803,7 @@ ] } + -- ------------------------------------------------------------ -- * GetOpt Utils -- ------------------------------------------------------------ @@ -2754,13 +2835,16 @@ -> (flags -> Flag Int ) -> (Flag Int -> flags -> flags) -> (flags -> Flag ReorderGoals) -> (Flag ReorderGoals -> flags -> flags) -> (flags -> Flag CountConflicts) -> (Flag CountConflicts -> flags -> flags) + -> (flags -> Flag MinimizeConflictSet) -> (Flag MinimizeConflictSet -> flags -> flags) -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags) -> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags) -> (flags -> Flag StrongFlags) -> (Flag StrongFlags -> flags -> flags) -> (flags -> Flag AllowBootLibInstalls) -> (Flag AllowBootLibInstalls -> flags -> flags) + -> (flags -> Flag OnlyConstrained) -> (Flag OnlyConstrained -> flags -> flags) -> [OptionField flags] -optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc getig setig - getsip setsip getstrfl setstrfl getib setib = +optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc + getmc setmc getig setig getsip setsip getstrfl setstrfl + getib setib getoc setoc = [ option [] ["max-backjumps"] ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") getmbj setmbj @@ -2776,6 +2860,13 @@ (fmap asBool . getcc) (setcc . fmap CountConflicts) (yesNoOpt showOrParseArgs) + , option [] ["minimize-conflict-set"] + ("When there is no solution, try to improve the error message by finding " + ++ "a minimal conflict set (default: false). May increase run time " + ++ "significantly.") + (fmap asBool . getmc) + (setmc . fmap MinimizeConflictSet) + (yesNoOpt showOrParseArgs) , option [] ["independent-goals"] "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." (fmap asBool . getig) @@ -2796,6 +2887,16 @@ (fmap asBool . getib) (setib . fmap AllowBootLibInstalls) (yesNoOpt showOrParseArgs) + , option [] ["reject-unconstrained-dependencies"] + "Require these packages to have constraints on them if they are to be selected (default: none)." + getoc + setoc + (reqArg "none|all" + (readP_to_E + (const "reject-unconstrained-dependencies must be 'none' or 'all'") + (toFlag `fmap` parse)) + (flagToList . fmap display)) + ] usageFlagsOrPackages :: String -> String -> String @@ -2828,8 +2929,8 @@ where pkgidToDependency :: PackageIdentifier -> Dependency pkgidToDependency p = case packageVersion p of - v | v == nullVersion -> Dependency (packageName p) anyVersion - | otherwise -> Dependency (packageName p) (thisVersion v) + v | v == nullVersion -> Dependency (packageName p) anyVersion (Set.singleton LMainLibName) + | otherwise -> Dependency (packageName p) (thisVersion v) (Set.singleton LMainLibName) showRepo :: RemoteRepo -> String showRepo repo = remoteRepoName repo ++ ":" diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs --- a/Distribution/Client/SetupWrapper.hs +++ b/Distribution/Client/SetupWrapper.hs @@ -36,7 +36,6 @@ ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId , PackageId, mkPackageName , PackageIdentifier(..), packageVersion, packageName ) -import Distribution.Types.Dependency import Distribution.PackageDescription ( GenericPackageDescription(packageDescription) , PackageDescription(..), specVersion, buildType @@ -97,7 +96,7 @@ import Distribution.ReadE import Distribution.System ( Platform(..), buildPlatform ) -import Distribution.Text +import Distribution.Deprecated.Text ( display ) import Distribution.Utils.NubList ( toNubListR ) @@ -128,11 +127,11 @@ -- | @Setup@ encapsulates the outcome of configuring a setup method to build a -- particular package. -data Setup = Setup { setupMethod :: SetupMethod +data Setup = Setup { setupMethod :: SetupMethod , setupScriptOptions :: SetupScriptOptions - , setupVersion :: Version - , setupBuildType :: BuildType - , setupPackage :: PackageDescription + , setupVersion :: Version + , setupBuildType :: BuildType + , setupPackage :: PackageDescription } -- | @SetupMethod@ represents one of the methods used to run Cabal commands. @@ -312,7 +311,7 @@ , setupPackage = pkg } where - getPkg = tryFindPackageDesc (fromMaybe "." (useWorkingDir options)) + getPkg = tryFindPackageDesc verbosity (fromMaybe "." (useWorkingDir options)) >>= readGenericPackageDescription verbosity >>= return . packageDescription @@ -719,10 +718,10 @@ return (packageVersion pkg, Nothing, options') installedCabalVersion options' compiler progdb = do index <- maybeGetInstalledPackages options' compiler progdb - let cabalDep = Dependency (mkPackageName "Cabal") - (useCabalVersion options') - options'' = options' { usePackageIndex = Just index } - case PackageIndex.lookupDependency index cabalDep of + let cabalDepName = mkPackageName "Cabal" + cabalDepVersion = useCabalVersion options' + options'' = options' { usePackageIndex = Just index } + case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of [] -> die' verbosity $ "The package '" ++ display (packageName pkg) ++ "' requires Cabal library version " ++ display (useCabalVersion options) diff --git a/Distribution/Client/SolverInstallPlan.hs b/Distribution/Client/SolverInstallPlan.hs --- a/Distribution/Client/SolverInstallPlan.hs +++ b/Distribution/Client/SolverInstallPlan.hs @@ -55,7 +55,7 @@ ( PackageIdentifier(..), Package(..), PackageName , HasUnitId(..), PackageId, packageVersion, packageName ) import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Text +import Distribution.Deprecated.Text ( display ) import Distribution.Client.Types diff --git a/Distribution/Client/SourceRepoParse.hs b/Distribution/Client/SourceRepoParse.hs --- a/Distribution/Client/SourceRepoParse.hs +++ b/Distribution/Client/SourceRepoParse.hs @@ -3,18 +3,19 @@ import Distribution.Client.Compat.Prelude import Prelude () +import Distribution.Deprecated.ParseUtils (FieldDescr (..), syntaxError) import Distribution.FieldGrammar.FieldDescrs (fieldDescrsToList) import Distribution.PackageDescription.FieldGrammar (sourceRepoFieldGrammar) -import Distribution.Parsec.Class (explicitEitherParsec) -import Distribution.ParseUtils (FieldDescr (..), syntaxError) -import Distribution.Types.SourceRepo (SourceRepo, RepoKind (..)) +import Distribution.Parsec (explicitEitherParsec) +import Distribution.Simple.Utils (fromUTF8BS) +import Distribution.Types.SourceRepo (RepoKind (..), SourceRepo) sourceRepoFieldDescrs :: [FieldDescr SourceRepo] sourceRepoFieldDescrs = map toDescr . fieldDescrsToList $ sourceRepoFieldGrammar (RepoKindUnknown "unused") where toDescr (name, pretty, parse) = FieldDescr - { fieldName = name + { fieldName = fromUTF8BS name , fieldGet = pretty , fieldSet = \lineNo str x -> either (syntaxError lineNo) return diff --git a/Distribution/Client/SrcDist.hs b/Distribution/Client/SrcDist.hs --- a/Distribution/Client/SrcDist.hs +++ b/Distribution/Client/SrcDist.hs @@ -24,16 +24,14 @@ ( readGenericPackageDescription ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, defaultPackageDesc - , warn, die', notice, withTempDirectory ) + , warn, notice, withTempDirectory ) import Distribution.Client.Setup - ( SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) ) + ( SDistFlags(..) ) import Distribution.Simple.Setup ( Flag(..), sdistCommand, flagToList, fromFlag, fromFlagOrDefault , defaultSDistFlags ) import Distribution.Simple.BuildPaths ( srcPref) -import Distribution.Simple.Program (requireProgram, simpleProgram, programPath) -import Distribution.Simple.Program.Db (emptyProgramDb) -import Distribution.Text ( display ) +import Distribution.Deprecated.Text ( display ) import Distribution.Verbosity (Verbosity, normal, lessVerbose) import Distribution.Version (mkVersion, orLaterVersion, intersectVersionRanges) @@ -43,14 +41,12 @@ import System.FilePath ((), (<.>)) import Control.Monad (when, unless, liftM) -import System.Directory (doesFileExist, removeFile, canonicalizePath, getTemporaryDirectory) -import System.Process (runProcess, waitForProcess) -import System.Exit (ExitCode(..)) +import System.Directory (getTemporaryDirectory) import Control.Exception (IOException, evaluate) -- |Create a source distribution. -sdist :: SDistFlags -> SDistExFlags -> IO () -sdist flags exflags = do +sdist :: SDistFlags -> IO () +sdist flags = do pkg <- liftM flattenPackageDescription (readGenericPackageDescription verbosity =<< defaultPackageDesc verbosity) let withDir :: (FilePath -> IO a) -> IO a @@ -74,7 +70,7 @@ -- Unless we were given --list-sources or --output-directory ourselves, -- create an archive. when needMakeArchive $ - createArchive verbosity pkg tmpDir distPref + createTarGzArchive verbosity pkg tmpDir distPref when isOutDirectory $ notice verbosity $ "Source directory created: " ++ tmpTargetDir @@ -100,10 +96,6 @@ then orLaterVersion $ mkVersion [1,17,0] else orLaterVersion $ mkVersion [1,12,0] } - format = fromFlag (sDistFormat exflags) - createArchive = case format of - TargzFormat -> createTarGzArchive - ZipFormat -> createZipArchive tarBallName :: PackageDescription -> String tarBallName = display . packageId @@ -116,38 +108,6 @@ notice verbosity $ "Source tarball created: " ++ tarBallFilePath where tarBallFilePath = targetPref tarBallName pkg <.> "tar.gz" - --- | Create a zip archive from a tree of source files. -createZipArchive :: Verbosity -> PackageDescription -> FilePath -> FilePath - -> IO () -createZipArchive verbosity pkg tmpDir targetPref = do - let dir = tarBallName pkg - zipfile = targetPref dir <.> "zip" - (zipProg, _) <- requireProgram verbosity zipProgram emptyProgramDb - - -- zip has an annoying habit of updating the target rather than creating - -- it from scratch. While that might sound like an optimisation, it doesn't - -- remove files already in the archive that are no longer present in the - -- uncompressed tree. - alreadyExists <- doesFileExist zipfile - when alreadyExists $ removeFile zipfile - - -- We call zip with a different CWD, so have to make the path - -- absolute. Can't just use 'canonicalizePath zipfile' since this function - -- requires its argument to refer to an existing file. - zipfileAbs <- fmap ( dir <.> "zip") . canonicalizePath $ targetPref - - --TODO: use runProgramInvocation, but has to be able to set CWD - hnd <- runProcess (programPath zipProg) ["-q", "-r", zipfileAbs, dir] - (Just tmpDir) - Nothing Nothing Nothing Nothing - exitCode <- waitForProcess hnd - unless (exitCode == ExitSuccess) $ - die' verbosity $ "Generating the zip file failed " - ++ "(zip returned exit code " ++ show exitCode ++ ")" - notice verbosity $ "Source zip archive created: " ++ zipfile - where - zipProgram = simpleProgram "zip" -- | List all source files of a given add-source dependency. Exits with error if -- something is wrong (e.g. there is no .cabal file in the given directory). diff --git a/Distribution/Client/Store.hs b/Distribution/Client/Store.hs --- a/Distribution/Client/Store.hs +++ b/Distribution/Client/Store.hs @@ -34,7 +34,7 @@ import Distribution.Simple.Utils ( withTempDirectory, debug, info ) import Distribution.Verbosity -import Distribution.Text +import Distribution.Deprecated.Text import Data.Set (Set) import qualified Data.Set as Set diff --git a/Distribution/Client/TargetSelector.hs b/Distribution/Client/TargetSelector.hs --- a/Distribution/Client/TargetSelector.hs +++ b/Distribution/Client/TargetSelector.hs @@ -61,11 +61,11 @@ import Distribution.ModuleName ( ModuleName, toFilePath ) import Distribution.Simple.LocalBuildInfo - ( Component(..), ComponentName(..) + ( Component(..), ComponentName(..), LibraryName(..) , pkgComponents, componentName, componentBuildInfo ) import Distribution.Types.ForeignLib -import Distribution.Text +import Distribution.Deprecated.Text ( Text, display, simpleParse ) import Distribution.Simple.Utils ( die', lowercase, ordNub ) @@ -86,10 +86,10 @@ import Control.Arrow ((&&&)) import Control.Monad hiding ( mfilter ) -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP +import qualified Distribution.Deprecated.ReadP as Parse +import Distribution.Deprecated.ReadP ( (+++), (<++) ) -import Distribution.ParseUtils +import Distribution.Deprecated.ParseUtils ( readPToMaybe ) import System.FilePath as FilePath ( takeExtension, dropExtension @@ -102,6 +102,7 @@ import Text.EditDistance ( defaultEditCosts, restrictedDamerauLevenshteinDistance ) +import qualified Prelude (foldr1) -- ------------------------------------------------------------ -- * Target selector terms @@ -552,8 +553,7 @@ go (TargetPackageNamed _ (Just filter')) = kfilter == filter' go (TargetAllPackages (Just filter')) = kfilter == filter' go (TargetComponent _ cname _) - | CLibName <- cname = kfilter == LibKind - | CSubLibName _ <- cname = kfilter == LibKind + | CLibName _ <- cname = kfilter == LibKind | CFLibName _ <- cname = kfilter == FLibKind | CExeName _ <- cname = kfilter == ExeKind | CTestName _ <- cname = kfilter == TestKind @@ -931,8 +931,8 @@ , syntaxForm7MetaNamespacePackageKindComponentNamespaceFile pinfo ] where - ambiguousAlternatives = foldr1 AmbiguousAlternatives - shadowingAlternatives = foldr1 ShadowingAlternatives + ambiguousAlternatives = Prelude.foldr1 AmbiguousAlternatives + shadowingAlternatives = Prelude.foldr1 ShadowingAlternatives -- | Syntax: "all" to select all packages in the project @@ -1183,7 +1183,7 @@ KnownPackageName pn -> do m <- matchModuleNameUnknown str2 -- We assume the primary library component of the package: - return (TargetComponentUnknown pn (Right CLibName) (ModuleTarget m)) + return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (ModuleTarget m)) where render (TargetComponent p _c (ModuleTarget m)) = [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)] @@ -1228,7 +1228,7 @@ KnownPackageName pn -> let filepath = str2 in -- We assume the primary library component of the package: - return (TargetComponentUnknown pn (Right CLibName) (FileTarget filepath)) + return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (FileTarget filepath)) where render (TargetComponent p _c (FileTarget f)) = [TargetStringFileStatus2 (dispP p) noFileStatus f] @@ -1799,8 +1799,8 @@ componentStringName :: PackageName -> ComponentName -> ComponentStringName -componentStringName pkgname CLibName = display pkgname -componentStringName _ (CSubLibName name) = unUnqualComponentName name +componentStringName pkgname (CLibName LMainLibName) = display pkgname +componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name componentStringName _ (CFLibName name) = unUnqualComponentName name componentStringName _ (CExeName name) = unUnqualComponentName name componentStringName _ (CTestName name) = unUnqualComponentName name @@ -1859,8 +1859,7 @@ -- componentKind :: ComponentName -> ComponentKind -componentKind CLibName = LibKind -componentKind (CSubLibName _) = LibKind +componentKind (CLibName _) = LibKind componentKind (CFLibName _) = FLibKind componentKind (CExeName _) = ExeKind componentKind (CTestName _) = TestKind @@ -2390,8 +2389,8 @@ case ckind of LibKind | packageNameToUnqualComponentName pkgname == ucname - -> CLibName - | otherwise -> CSubLibName ucname + -> CLibName LMainLibName + | otherwise -> CLibName $ LSubLibName ucname FLibKind -> CFLibName ucname ExeKind -> CExeName ucname TestKind -> CTestName ucname diff --git a/Distribution/Client/Targets.hs b/Distribution/Client/Targets.hs --- a/Distribution/Client/Targets.hs +++ b/Distribution/Client/Targets.hs @@ -50,10 +50,13 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Deprecated.ParseUtils (parseFlagAssignment) + import Distribution.Package ( Package(..), PackageName, unPackageName, mkPackageName , PackageIdentifier(..), packageName, packageVersion ) import Distribution.Types.Dependency +import Distribution.Types.LibraryName import Distribution.Client.Types ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage , PackageSpecifier(..) ) @@ -75,10 +78,10 @@ ( RepoContext(..) ) import Distribution.PackageDescription - ( GenericPackageDescription, parseFlagAssignment, nullFlagAssignment ) + ( GenericPackageDescription, nullFlagAssignment) import Distribution.Version ( nullVersion, thisVersion, anyVersion, isAnyVersion ) -import Distribution.Text +import Distribution.Deprecated.Text ( Text(..), display ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils @@ -91,13 +94,14 @@ import Data.Either ( partitionEithers ) import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Data.ByteString.Lazy as BS import qualified Distribution.Client.GZipUtils as GZipUtils import Control.Monad (mapM) -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP +import qualified Distribution.Deprecated.ReadP as Parse +import Distribution.Deprecated.ReadP ( (+++), (<++) ) -import Distribution.ParseUtils +import Distribution.Deprecated.ParseUtils ( readPToMaybe ) import System.FilePath ( takeExtension, dropExtension, takeDirectory, splitPath ) @@ -187,7 +191,7 @@ readUserTarget :: String -> IO (Either UserTargetProblem UserTarget) readUserTarget targetstr = case testNamedTargets targetstr of - Just (Dependency pkgn verrange) + Just (Dependency pkgn verrange _) | pkgn == mkPackageName "world" -> return $ if verrange == anyVersion then Right UserTargetWorld @@ -255,8 +259,8 @@ where pkgidToDependency :: PackageIdentifier -> Dependency pkgidToDependency p = case packageVersion p of - v | v == nullVersion -> Dependency (packageName p) anyVersion - | otherwise -> Dependency (packageName p) (thisVersion v) + v | v == nullVersion -> Dependency (packageName p) anyVersion (Set.singleton LMainLibName) + | otherwise -> Dependency (packageName p) (thisVersion v) (Set.singleton LMainLibName) reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO () @@ -376,7 +380,7 @@ -> IO [PackageTarget (PackageLocation ())] expandUserTarget verbosity worldFile userTarget = case userTarget of - UserTargetNamed (Dependency name vrange) -> + UserTargetNamed (Dependency name vrange _cs) -> let props = [ PackagePropertyVersion vrange | not (isAnyVersion vrange) ] in return [PackageTargetNamedFuzzy name props userTarget] @@ -385,7 +389,7 @@ worldPkgs <- World.getContents verbosity worldFile --TODO: should we warn if there are no world targets? return [ PackageTargetNamed name props userTarget - | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs + | World.WorldPkgInfo (Dependency name vrange _) flags <- worldPkgs , let props = [ PackagePropertyVersion vrange | not (isAnyVersion vrange) ] ++ [ PackagePropertyFlags flags @@ -774,7 +778,7 @@ -- don't get an ambiguous parse from 'installed', -- 'source', etc. being regarded as flags. <++ - (Parse.skipSpaces1 >> parseFlagAssignment + (Parse.skipSpaces1 >> parseFlagAssignment >>= return . PackagePropertyFlags) -- Result diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs --- a/Distribution/Client/Types.hs +++ b/Distribution/Client/Types.hs @@ -46,6 +46,8 @@ ( PackageName, mkPackageName ) import Distribution.Types.ComponentName ( ComponentName(..) ) +import Distribution.Types.LibraryName + ( LibraryName(..) ) import Distribution.Types.SourceRepo ( SourceRepo ) @@ -61,10 +63,10 @@ import Distribution.Solver.Types.PackageFixedDeps import Distribution.Solver.Types.SourcePackage import Distribution.Compat.Graph (IsNode(..)) -import qualified Distribution.Compat.ReadP as Parse -import Distribution.ParseUtils (parseOptCommaList) +import qualified Distribution.Deprecated.ReadP as Parse +import Distribution.Deprecated.ParseUtils (parseOptCommaList) import Distribution.Simple.Utils (ordNub) -import Distribution.Text (Text(..)) +import Distribution.Deprecated.Text (Text(..)) import Network.URI (URI(..), URIAuth(..), nullURI) import Control.Exception @@ -109,7 +111,7 @@ -- final configure process will be independent of the environment. -- -- 'ConfiguredPackage' is assumed to not support Backpack. Only the --- @new-build@ codepath supports Backpack. +-- @v2-build@ codepath supports Backpack. -- data ConfiguredPackage loc = ConfiguredPackage { confPkgId :: InstalledPackageId, @@ -129,7 +131,7 @@ -- 'ElaboratedPackage' and 'ElaboratedComponent'. -- instance HasConfiguredId (ConfiguredPackage loc) where - configuredId pkg = ConfiguredId (packageId pkg) (Just CLibName) (confPkgId pkg) + configuredId pkg = ConfiguredId (packageId pkg) (Just (CLibName LMainLibName)) (confPkgId pkg) -- 'ConfiguredPackage' is the legacy codepath, we are guaranteed -- to never have a nontrivial 'UnitId' @@ -181,7 +183,7 @@ packageId cpkg = packageId (confPkgSource cpkg) instance HasMungedPackageId (ConfiguredPackage loc) where - mungedId cpkg = computeCompatPackageId (packageId cpkg) Nothing + mungedId cpkg = computeCompatPackageId (packageId cpkg) LMainLibName -- Never has nontrivial UnitId instance HasUnitId (ConfiguredPackage loc) where @@ -595,8 +597,8 @@ -- ------------------------------------------------------------ -- | Whether 'v2-build' should write a .ghc.environment file after --- success. Possible values: 'always', 'never', 'ghc8.4.4+' (the --- default; GHC 8.4.4 is the earliest version that supports +-- success. Possible values: 'always', 'never' (the default), 'ghc8.4.4+' +-- (8.4.4 is the earliest version that supports -- '-package-env -'). data WriteGhcEnvironmentFilesPolicy = AlwaysWriteGhcEnvironmentFiles diff --git a/Distribution/Client/Update.hs b/Distribution/Client/Update.hs --- a/Distribution/Client/Update.hs +++ b/Distribution/Client/Update.hs @@ -33,7 +33,7 @@ ( newParallelJobControl, spawnJob, collectJob ) import Distribution.Client.Setup ( RepoContext(..), UpdateFlags(..) ) -import Distribution.Text +import Distribution.Deprecated.Text ( display ) import Distribution.Verbosity diff --git a/Distribution/Client/Upload.hs b/Distribution/Client/Upload.hs --- a/Distribution/Client/Upload.hs +++ b/Distribution/Client/Upload.hs @@ -9,13 +9,13 @@ import Distribution.Simple.Utils (notice, warn, info, die') import Distribution.Verbosity (Verbosity) -import Distribution.Text (display) +import Distribution.Deprecated.Text (display) import Distribution.Client.Config import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import qualified Distribution.Client.BuildReports.Upload as BuildReport -import Network.URI (URI(uriPath)) +import Network.URI (URI(uriPath, uriAuthority), URIAuth(uriRegName)) import Network.HTTP (Header(..), HeaderName(..)) import System.IO (hFlush, stdout) @@ -52,6 +52,7 @@ [] -> die' verbosity "Cannot upload. No remote repositories are configured." rs -> remoteRepoTryUpgradeToHttps verbosity transport (last rs) let targetRepoURI = remoteRepoURI targetRepo + domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI rootIfEmpty x = if null x then "/" else x uploadURI = targetRepoURI { uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix. @@ -68,8 +69,8 @@ IsPublished -> "" ] } - Username username <- maybe promptUsername return mUsername - Password password <- maybe promptPassword return mPassword + Username username <- maybe (promptUsername domain) return mUsername + Password password <- maybe (promptPassword domain) return mPassword let auth = Just (username,password) forM_ paths $ \path -> do notice verbosity $ "Uploading " ++ path ++ "... " @@ -91,6 +92,7 @@ [] -> die' verbosity $ "Cannot upload. No remote repositories are configured." rs -> remoteRepoTryUpgradeToHttps verbosity transport (last rs) let targetRepoURI = remoteRepoURI targetRepo + domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI rootIfEmpty x = if null x then "/" else x uploadURI = targetRepoURI { uriPath = rootIfEmpty (uriPath targetRepoURI) @@ -117,8 +119,8 @@ when (reverse reverseSuffix /= "docs.tar.gz" || null reversePkgid || head reversePkgid /= '-') $ die' verbosity "Expected a file name matching the pattern -docs.tar.gz" - Username username <- maybe promptUsername return mUsername - Password password <- maybe promptPassword return mPassword + Username username <- maybe (promptUsername domain) return mUsername + Password password <- maybe (promptPassword domain) return mPassword let auth = Just (username,password) headers = @@ -149,15 +151,15 @@ ++ show packageUri ++ "'." -promptUsername :: IO Username -promptUsername = do - putStr "Hackage username: " +promptUsername :: String -> IO Username +promptUsername domain = do + putStr $ domain ++ " username: " hFlush stdout fmap Username getLine -promptPassword :: IO Password -promptPassword = do - putStr "Hackage password: " +promptPassword :: String -> IO Password +promptPassword domain = do + putStr $ domain ++ " password: " hFlush stdout -- save/restore the terminal echoing status (no echoing for entering the password) passwd <- withoutInputEcho $ fmap Password getLine @@ -166,30 +168,32 @@ report :: Verbosity -> RepoContext -> Maybe Username -> Maybe Password -> IO () report verbosity repoCtxt mUsername mPassword = do - Username username <- maybe promptUsername return mUsername - Password password <- maybe promptPassword return mPassword - let auth = (username, password) - repos = repoContextRepos repoCtxt + let repos = repoContextRepos repoCtxt remoteRepos = mapMaybe maybeRepoRemote repos - forM_ remoteRepos $ \remoteRepo -> - do dotCabal <- getCabalDir - let srcDir = dotCabal "reports" remoteRepoName remoteRepo - -- We don't want to bomb out just because we haven't built any packages - -- from this repo yet. - srcExists <- doesDirectoryExist srcDir - when srcExists $ do - contents <- getDirectoryContents srcDir - forM_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile -> - do inp <- readFile (srcDir logFile) - let (reportStr, buildLog) = read inp :: (String,String) -- TODO: eradicateNoParse - case BuildReport.parse reportStr of - Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME - Right report' -> - do info verbosity $ "Uploading report for " - ++ display (BuildReport.package report') - BuildReport.uploadReports verbosity repoCtxt auth - (remoteRepoURI remoteRepo) [(report', Just buildLog)] - return () + forM_ remoteRepos $ \remoteRepo -> do + let domain = maybe "Hackage" uriRegName $ uriAuthority (remoteRepoURI remoteRepo) + Username username <- maybe (promptUsername domain) return mUsername + Password password <- maybe (promptPassword domain) return mPassword + let auth = (username, password) + + dotCabal <- getCabalDir + let srcDir = dotCabal "reports" remoteRepoName remoteRepo + -- We don't want to bomb out just because we haven't built any packages + -- from this repo yet. + srcExists <- doesDirectoryExist srcDir + when srcExists $ do + contents <- getDirectoryContents srcDir + forM_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile -> + do inp <- readFile (srcDir logFile) + let (reportStr, buildLog) = read inp :: (String,String) -- TODO: eradicateNoParse + case BuildReport.parse reportStr of + Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME + Right report' -> + do info verbosity $ "Uploading report for " + ++ display (BuildReport.package report') + BuildReport.uploadReports verbosity repoCtxt auth + (remoteRepoURI remoteRepo) [(report', Just buildLog)] + return () handlePackage :: HttpTransport -> Verbosity -> URI -> URI -> Auth -> IsCandidate -> FilePath -> IO () diff --git a/Distribution/Client/Utils/Parsec.hs b/Distribution/Client/Utils/Parsec.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Utils/Parsec.hs @@ -0,0 +1,102 @@ +module Distribution.Client.Utils.Parsec ( + renderParseError, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () +import System.FilePath (normalise) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 + +import Distribution.Parsec (PError (..), PWarning (..), Position (..), showPos, zeroPos) +import Distribution.Simple.Utils (fromUTF8BS) + +-- | Render parse error highlighting the part of the input file. +renderParseError + :: FilePath + -> BS.ByteString + -> [PError] + -> [PWarning] + -> String +renderParseError filepath contents errors warnings = unlines $ + [ "Errors encountered when parsing cabal file " <> filepath <> ":" + ] + ++ renderedErrors + ++ renderedWarnings + where + filepath' = normalise filepath + + -- lines of the input file. 'lines' is taken, so they are called rows + -- contents, line number, whether it's empty line + rows :: [(String, Int, Bool)] + rows = zipWith f (BS8.lines contents) [1..] where + f bs i = let s = fromUTF8BS bs in (s, i, isEmptyOrComment s) + + rowsZipper = listToZipper rows + + isEmptyOrComment :: String -> Bool + isEmptyOrComment s = case dropWhile (== ' ') s of + "" -> True -- empty + ('-':'-':_) -> True -- comment + _ -> False + + renderedErrors = concatMap renderError errors + renderedWarnings = concatMap renderWarning warnings + + renderError :: PError -> [String] + renderError (PError pos@(Position row col) msg) + -- if position is 0:0, then it doesn't make sense to show input + -- looks like, Parsec errors have line-feed in them + | pos == zeroPos = msgs + | otherwise = msgs ++ formatInput row col + where + msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": error:", trimLF msg, "" ] + + renderWarning :: PWarning -> [String] + renderWarning (PWarning _ pos@(Position row col) msg) + | pos == zeroPos = msgs + | otherwise = msgs ++ formatInput row col + where + msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": warning:", trimLF msg, "" ] + + -- sometimes there are (especially trailing) newlines. + trimLF :: String -> String + trimLF = dropWhile (== '\n') . reverse . dropWhile (== '\n') . reverse + + -- format line: prepend the given line number + formatInput :: Int -> Int -> [String] + formatInput row col = case advance (row - 1) rowsZipper of + Zipper xs ys -> before ++ after where + before = case span (\(_, _, b) -> b) xs of + (_, []) -> [] + (zs, z : _) -> map formatInputLine $ z : reverse zs + + after = case ys of + [] -> [] + (z : _zs) -> + [ formatInputLine z -- error line + , " | " ++ replicate (col - 1) ' ' ++ "^" -- pointer: ^ + ] + -- do we need rows after? + -- ++ map formatInputLine (take 1 zs) -- one row after + + formatInputLine :: (String, Int, Bool) -> String + formatInputLine (str, row, _) = leftPadShow row ++ " | " ++ str + + -- hopefully we don't need to work with over 99999 lines .cabal files + -- at that point small glitches in error messages are hopefully fine. + leftPadShow :: Int -> String + leftPadShow n = let s = show n in replicate (5 - length s) ' ' ++ s + +data Zipper a = Zipper [a] [a] + +listToZipper :: [a] -> Zipper a +listToZipper = Zipper [] + +advance :: Int -> Zipper a -> Zipper a +advance n z@(Zipper xs ys) + | n <= 0 = z + | otherwise = case ys of + [] -> z + (y:ys') -> advance (n - 1) $ Zipper (y:xs) ys' diff --git a/Distribution/Client/World.hs b/Distribution/Client/World.hs --- a/Distribution/Client/World.hs +++ b/Distribution/Client/World.hs @@ -40,9 +40,9 @@ ( Verbosity ) import Distribution.Simple.Utils ( die', info, chattyTry, writeFileAtomic ) -import Distribution.Text +import Distribution.Deprecated.Text ( Text(..), display, simpleParse ) -import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Deprecated.ReadP as Parse import Distribution.Compat.Exception ( catchIO ) import qualified Text.PrettyPrint as Disp @@ -74,8 +74,8 @@ -- | WorldPkgInfo values are considered equal if they refer to -- the same package, i.e., we don't care about differing versions or flags. equalUDep :: WorldPkgInfo -> WorldPkgInfo -> Bool -equalUDep (WorldPkgInfo (Dependency pkg1 _) _) - (WorldPkgInfo (Dependency pkg2 _) _) = pkg1 == pkg2 +equalUDep (WorldPkgInfo (Dependency pkg1 _ _) _) + (WorldPkgInfo (Dependency pkg2 _ _) _) = pkg1 == pkg2 -- | Modifies the world file by applying an update-function ('unionBy' -- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of diff --git a/Distribution/Deprecated/ParseUtils.hs b/Distribution/Deprecated/ParseUtils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Deprecated/ParseUtils.hs @@ -0,0 +1,724 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Deprecated.ParseUtils +-- Copyright : (c) The University of Glasgow 2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'. +-- +-- The @.cabal@ file format is not trivial, especially with the introduction +-- of configurations and the section syntax that goes with that. This module +-- has a bunch of parsing functions that is used by the @.cabal@ parser and a +-- couple others. It has the parsing framework code and also little parsers for +-- many of the formats we get in various @.cabal@ file fields, like module +-- names, comma separated lists etc. + +-- This module is meant to be local-only to Distribution... + +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE Rank2Types #-} +module Distribution.Deprecated.ParseUtils ( + LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning, + runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning, + Field(..), fName, lineNo, + FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat, + showFields, showSingleNamedField, showSimpleSingleNamedField, + parseFields, parseFieldsFlat, + parseHaskellString, parseFilePathQ, parseTokenQ, parseTokenQ', + parseModuleNameQ, + parseFlagAssignment, + parseOptVersion, parsePackageName, + parseSepList, parseCommaList, parseOptCommaList, + showFilePath, showToken, showTestedWith, showFreeText, parseFreeText, + field, simpleField, listField, listFieldWithSep, spaceListField, + commaListField, commaListFieldWithSep, commaNewLineListField, newLineListField, + optsField, liftField, boolField, parseQuoted, parseMaybeQuoted, + readPToMaybe, + + UnrecFieldParser, warnUnrec, ignoreUnrec, + ) where + +import Distribution.Client.Compat.Prelude hiding (get) +import Prelude () + +import Distribution.Deprecated.ReadP as ReadP hiding (get) +import Distribution.Deprecated.Text + +import Distribution.Compat.Newtype +import Distribution.Compiler +import Distribution.ModuleName +import Distribution.Parsec.Newtypes (TestedWith (..)) +import Distribution.Pretty +import Distribution.ReadE +import Distribution.Utils.Generic +import Distribution.Version +import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment) + +import Data.Tree as Tree (Tree (..), flatten) +import System.FilePath (normalise) +import Text.PrettyPrint + (Doc, Mode (..), colon, comma, fsep, hsep, isEmpty, mode, nest, punctuate, render, + renderStyle, sep, style, text, vcat, ($+$), (<+>)) +import qualified Text.Read as Read +import qualified Data.Map as Map + +import qualified Control.Monad.Fail as Fail + +-- ----------------------------------------------------------------------------- + +type LineNo = Int + +data PError = AmbiguousParse String LineNo + | NoParse String LineNo + | TabsError LineNo + | FromString String (Maybe LineNo) + deriving (Eq, Show) + +data PWarning = PWarning String + | UTFWarning LineNo String + deriving (Eq, Show) + +showPWarning :: FilePath -> PWarning -> String +showPWarning fpath (PWarning msg) = + normalise fpath ++ ": " ++ msg +showPWarning fpath (UTFWarning line fname) = + normalise fpath ++ ":" ++ show line + ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field." + +data ParseResult a = ParseFailed PError | ParseOk [PWarning] a + deriving Show + +instance Functor ParseResult where + fmap _ (ParseFailed err) = ParseFailed err + fmap f (ParseOk ws x) = ParseOk ws $ f x + +instance Applicative ParseResult where + pure = ParseOk [] + (<*>) = ap + + +instance Monad ParseResult where + return = pure + ParseFailed err >>= _ = ParseFailed err + ParseOk ws x >>= f = case f x of + ParseFailed err -> ParseFailed err + ParseOk ws' x' -> ParseOk (ws'++ws) x' + +#if !(MIN_VERSION_base(4,9,0)) + fail = parseResultFail +#elif !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif + +instance Fail.MonadFail ParseResult where + fail = parseResultFail + +parseResultFail :: String -> ParseResult a +parseResultFail s = parseFail (FromString s Nothing) + + +catchParseError :: ParseResult a -> (PError -> ParseResult a) + -> ParseResult a +p@(ParseOk _ _) `catchParseError` _ = p +ParseFailed e `catchParseError` k = k e + +parseFail :: PError -> ParseResult a +parseFail = ParseFailed + +runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a +runP line fieldname p s = + case [ x | (x,"") <- results ] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + --TODO: what is this double parse thing all about? + -- Can't we just do the all isSpace test the first time? + [] -> case [ x | (x,ys) <- results, all isSpace ys ] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + [] -> ParseFailed (NoParse fieldname line) + _ -> ParseFailed (AmbiguousParse fieldname line) + _ -> ParseFailed (AmbiguousParse fieldname line) + where results = readP_to_S p s + +runE :: LineNo -> String -> ReadE a -> String -> ParseResult a +runE line fieldname p s = + case runReadE p s of + Right a -> ParseOk (utf8Warnings line fieldname s) a + Left e -> syntaxError line $ + "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s + +utf8Warnings :: LineNo -> String -> String -> [PWarning] +utf8Warnings line fieldname s = + take 1 [ UTFWarning n fieldname + | (n,l) <- zip [line..] (lines s) + , '\xfffd' `elem` l ] + +locatedErrorMsg :: PError -> (Maybe LineNo, String) +locatedErrorMsg (AmbiguousParse f n) = (Just n, + "Ambiguous parse in field '"++f++"'.") +locatedErrorMsg (NoParse f n) = (Just n, + "Parse of field '"++f++"' failed.") +locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.") +locatedErrorMsg (FromString s n) = (n, s) + +syntaxError :: LineNo -> String -> ParseResult a +syntaxError n s = ParseFailed $ FromString s (Just n) + +tabsError :: LineNo -> ParseResult a +tabsError ln = ParseFailed $ TabsError ln + +warning :: String -> ParseResult () +warning s = ParseOk [PWarning s] () + +-- | Field descriptor. The parameter @a@ parameterizes over where the field's +-- value is stored in. +data FieldDescr a + = FieldDescr + { fieldName :: String + , fieldGet :: a -> Doc + , fieldSet :: LineNo -> String -> a -> ParseResult a + -- ^ @fieldSet n str x@ Parses the field value from the given input + -- string @str@ and stores the result in @x@ if the parse was + -- successful. Otherwise, reports an error on line number @n@. + } + +field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a +field name showF readF = + FieldDescr name showF (\line val _st -> runP line name readF val) + +-- Lift a field descriptor storing into an 'a' to a field descriptor storing +-- into a 'b'. +liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b +liftField get set (FieldDescr name showF parseF) + = FieldDescr name (showF . get) + (\line str b -> do + a <- parseF line str (get b) + return (set a b)) + +-- Parser combinator for simple fields. Takes a field name, a pretty printer, +-- a parser function, an accessor, and a setter, returns a FieldDescr over the +-- compoid structure. +simpleField :: String -> (a -> Doc) -> ReadP a a + -> (b -> a) -> (a -> b -> b) -> FieldDescr b +simpleField name showF readF get set + = liftField get set $ field name showF readF + +commaListFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaListFieldWithSep separator name showF readF get set = + liftField get set' $ + field name showF' (parseCommaList readF) + where + set' xs b = set (get b ++ xs) b + showF' = separator . punctuate comma . map showF + +commaListField :: String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaListField = commaListFieldWithSep fsep + +commaNewLineListField :: String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaNewLineListField = commaListFieldWithSep sep + +spaceListField :: String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +spaceListField name showF readF get set = + liftField get set' $ + field name showF' (parseSpaceList readF) + where + set' xs b = set (get b ++ xs) b + showF' = fsep . map showF + +-- this is a different definition from listField, like +-- commaNewLineListField it pretty prints on multiple lines +newLineListField :: String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +newLineListField = listFieldWithSep sep + +listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listFieldWithSep separator name showF readF get set = + liftField get set' $ + field name showF' (parseOptCommaList readF) + where + set' xs b = set (get b ++ xs) b + showF' = separator . map showF + +listField :: String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listField = listFieldWithSep fsep + +optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) + -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b +optsField name flavor get set = + liftField (fromMaybe [] . lookup flavor . get) + (\opts b -> set (reorder (update flavor opts (get b))) b) $ + field name showF (sepBy parseTokenQ' (munch1 isSpace)) + where + update _ opts l | all null opts = l --empty opts as if no opts + update f opts [] = [(f,opts)] + update f opts ((f',opts'):rest) + | f == f' = (f, opts' ++ opts) : rest + | otherwise = (f',opts') : update f opts rest + reorder = sortBy (comparing fst) + showF = hsep . map text + +-- TODO: this is a bit smelly hack. It's because we want to parse bool fields +-- liberally but not accept new parses. We cannot do that with ReadP +-- because it does not support warnings. We need a new parser framework! +boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b +boolField name get set = liftField get set (FieldDescr name showF readF) + where + showF = text . show + readF line str _ + | str == "True" = ParseOk [] True + | str == "False" = ParseOk [] False + | lstr == "true" = ParseOk [caseWarning] True + | lstr == "false" = ParseOk [caseWarning] False + | otherwise = ParseFailed (NoParse name line) + where + lstr = lowercase str + caseWarning = PWarning $ + "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'." + +ppFields :: [FieldDescr a] -> a -> Doc +ppFields fields x = + vcat [ ppField name (getter x) | FieldDescr name getter _ <- fields ] +showFields :: [FieldDescr a] -> a -> String +showFields fields = render . ($+$ text "") . ppFields fields + +showSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String) +showSingleNamedField fields f = + case [ get | (FieldDescr f' get _) <- fields, f' == f ] of + [] -> Nothing + (get:_) -> Just (render . ppField f . get) + +showSimpleSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String) +showSimpleSingleNamedField fields f = + case [ get | (FieldDescr f' get _) <- fields, f' == f ] of + [] -> Nothing + (get:_) -> Just (renderStyle myStyle . get) + where myStyle = style { mode = LeftMode } + +parseFields :: [FieldDescr a] -> a -> String -> ParseResult a +parseFields fields initial str = + readFields str >>= accumFields fields initial + +parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a +parseFieldsFlat fields initial str = + readFieldsFlat str >>= accumFields fields initial + +accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a +accumFields fields = foldM setField + where + fieldMap = Map.fromList + [ (name, f) | f@(FieldDescr name _ _) <- fields ] + setField accum (F line name value) = case Map.lookup name fieldMap of + Just (FieldDescr _ _ set) -> set line value accum + Nothing -> do + warning ("Unrecognized field " ++ name ++ " on line " ++ show line) + return accum + setField accum f = do + warning ("Unrecognized stanza on line " ++ show (lineNo f)) + return accum + +-- | The type of a function which, given a name-value pair of an +-- unrecognized field, and the current structure being built, +-- decides whether to incorporate the unrecognized field +-- (by returning Just x, where x is a possibly modified version +-- of the structure being built), or not (by returning Nothing). +type UnrecFieldParser a = (String,String) -> a -> Maybe a + +-- | A default unrecognized field parser which simply returns Nothing, +-- i.e. ignores all unrecognized fields, so warnings will be generated. +warnUnrec :: UnrecFieldParser a +warnUnrec _ _ = Nothing + +-- | A default unrecognized field parser which silently (i.e. no +-- warnings will be generated) ignores unrecognized fields, by +-- returning the structure being built unmodified. +ignoreUnrec :: UnrecFieldParser a +ignoreUnrec _ = Just + +------------------------------------------------------------------------------ + +-- The data type for our three syntactic categories +data Field + = F LineNo String String + -- ^ A regular @: @ field + | Section LineNo String String [Field] + -- ^ A section with a name and possible parameter. The syntactic + -- structure is: + -- + -- @ + -- { + -- * + -- } + -- @ + | IfBlock LineNo String [Field] [Field] + -- ^ A conditional block with an optional else branch: + -- + -- @ + -- if { + -- * + -- } else { + -- * + -- } + -- @ + deriving (Show + ,Eq) -- for testing + +lineNo :: Field -> LineNo +lineNo (F n _ _) = n +lineNo (Section n _ _ _) = n +lineNo (IfBlock n _ _ _) = n + +fName :: Field -> String +fName (F _ n _) = n +fName (Section _ n _ _) = n +fName _ = error "fname: not a field or section" + +readFields :: String -> ParseResult [Field] +readFields input = ifelse + =<< traverse (mkField 0) + =<< mkTree tokens + + where ls = (lines . normaliseLineEndings) input + tokens = (concatMap tokeniseLine . trimLines) ls + +readFieldsFlat :: String -> ParseResult [Field] +readFieldsFlat input = traverse (mkField 0) + =<< mkTree tokens + where ls = (lines . normaliseLineEndings) input + tokens = (concatMap tokeniseLineFlat . trimLines) ls + +-- attach line number and determine indentation +trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)] +trimLines ls = [ (lineno, indent, hastabs, trimTrailing l') + | (lineno, l) <- zip [1..] ls + , let (sps, l') = span isSpace l + indent = length sps + hastabs = '\t' `elem` sps + , validLine l' ] + where validLine ('-':'-':_) = False -- Comment + validLine [] = False -- blank line + validLine _ = True + +-- | We parse generically based on indent level and braces '{' '}'. To do that +-- we split into lines and then '{' '}' tokens and other spans within a line. +data Token = + -- | The 'Line' token is for bits that /start/ a line, eg: + -- + -- > "\n blah blah { blah" + -- + -- tokenises to: + -- + -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"] + -- + -- so lines are the only ones that can have nested layout, since they + -- have a known indentation level. + -- + -- eg: we can't have this: + -- + -- > if ... { + -- > } else + -- > other + -- + -- because other cannot nest under else, since else doesn't start a line + -- so cannot have nested layout. It'd have to be: + -- + -- > if ... { + -- > } + -- > else + -- > other + -- + -- but that's not so common, people would normally use layout or + -- brackets not both in a single @if else@ construct. + -- + -- > if ... { foo : bar } + -- > else + -- > other + -- + -- this is OK + Line LineNo Indent HasTabs String + | Span LineNo String -- ^ span in a line, following brackets + | OpenBracket LineNo | CloseBracket LineNo + +type Indent = Int +type HasTabs = Bool + +-- | Tokenise a single line, splitting on '{' '}' and the spans in between. +-- Also trims leading & trailing space on those spans within the line. +tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token] +tokeniseLine (n0, i, t, l) = case split n0 l of + (Span _ l':ss) -> Line n0 i t l' :ss + cs -> cs + where split _ "" = [] + split n s = case span (\c -> c /='}' && c /= '{') s of + ("", '{' : s') -> OpenBracket n : split n s' + (w , '{' : s') -> mkspan n w (OpenBracket n : split n s') + ("", '}' : s') -> CloseBracket n : split n s' + (w , '}' : s') -> mkspan n w (CloseBracket n : split n s') + (w , _) -> mkspan n w [] + + mkspan n s ss | null s' = ss + | otherwise = Span n s' : ss + where s' = trimTrailing (trimLeading s) + +tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token] +tokeniseLineFlat (n0, i, t, l) + | null l' = [] + | otherwise = [Line n0 i t l'] + where + l' = trimTrailing (trimLeading l) + +trimLeading, trimTrailing :: String -> String +trimLeading = dropWhile isSpace +trimTrailing = dropWhileEndLE isSpace + + +type SyntaxTree = Tree (LineNo, HasTabs, String) + +-- | Parse the stream of tokens into a tree of them, based on indent \/ layout +mkTree :: [Token] -> ParseResult [SyntaxTree] +mkTree toks = + layout 0 [] toks >>= \(trees, trailing) -> case trailing of + [] -> return trees + OpenBracket n:_ -> syntaxError n "mismatched brackets, unexpected {" + CloseBracket n:_ -> syntaxError n "mismatched brackets, unexpected }" + -- the following two should never happen: + Span n l :_ -> syntaxError n $ "unexpected span: " ++ show l + Line n _ _ l :_ -> syntaxError n $ "unexpected line: " ++ show l + + +-- | Parse the stream of tokens into a tree of them, based on indent +-- This parse state expect to be in a layout context, though possibly +-- nested within a braces context so we may still encounter closing braces. +layout :: Indent -- ^ indent level of the parent\/previous line + -> [SyntaxTree] -- ^ accumulating param, trees in this level + -> [Token] -- ^ remaining tokens + -> ParseResult ([SyntaxTree], [Token]) + -- ^ collected trees on this level and trailing tokens +layout _ a [] = return (reverse a, []) +layout i a (s@(Line _ i' _ _):ss) | i' < i = return (reverse a, s:ss) +layout i a (Line n _ t l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + layout i (Node (n,t,l) sub:a) ss' + +layout i a (Span n l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + layout i (Node (n,False,l) sub:a) ss' + +-- look ahead to see if following lines are more indented, giving a sub-tree +layout i a (Line n i' t l:ss) = do + lookahead <- layout (i'+1) [] ss + case lookahead of + ([], _) -> layout i (Node (n,t,l) [] :a) ss + (ts, ss') -> layout i (Node (n,t,l) ts :a) ss' + +layout _ _ ( OpenBracket n :_) = syntaxError n "unexpected '{'" +layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss) +layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: " + ++ show l + +-- | Parse the stream of tokens into a tree of them, based on explicit braces +-- This parse state expects to find a closing bracket. +braces :: LineNo -- ^ line of the '{', used for error messages + -> [SyntaxTree] -- ^ accumulating param, trees in this level + -> [Token] -- ^ remaining tokens + -> ParseResult ([SyntaxTree],[Token]) + -- ^ collected trees on this level and trailing tokens +braces m a (Line n _ t l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + braces m (Node (n,t,l) sub:a) ss' + +braces m a (Span n l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + braces m (Node (n,False,l) sub:a) ss' + +braces m a (Line n i t l:ss) = do + lookahead <- layout (i+1) [] ss + case lookahead of + ([], _) -> braces m (Node (n,t,l) [] :a) ss + (ts, ss') -> braces m (Node (n,t,l) ts :a) ss' + +braces m a (Span n l:ss) = braces m (Node (n,False,l) []:a) ss +braces _ a (CloseBracket _:ss) = return (reverse a, ss) +braces n _ [] = syntaxError n $ "opening brace '{'" + ++ "has no matching closing brace '}'" +braces _ _ (OpenBracket n:_) = syntaxError n "unexpected '{'" + +-- | Convert the parse tree into the Field AST +-- Also check for dodgy uses of tabs in indentation. +mkField :: Int -> SyntaxTree -> ParseResult Field +mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n +mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of + ([], _) -> syntaxError n $ "unrecognised field or section: " ++ show l + (name, rest) -> case trimLeading rest of + (':':rest') -> do let followingLines = concatMap Tree.flatten ts + tabs = not (null [()| (_,True,_) <- followingLines ]) + if tabs && d >= 1 + then tabsError n + else return $ F n (map toLower name) + (fieldValue rest' followingLines) + rest' -> do ts' <- traverse (mkField (d+1)) ts + return (Section n (map toLower name) rest' ts') + where fieldValue firstLine followingLines = + let firstLine' = trimLeading firstLine + followingLines' = map (\(_,_,s) -> stripDot s) followingLines + allLines | null firstLine' = followingLines' + | otherwise = firstLine' : followingLines' + in intercalate "\n" allLines + stripDot "." = "" + stripDot s = s + +-- | Convert if/then/else 'Section's to 'IfBlock's +ifelse :: [Field] -> ParseResult [Field] +ifelse [] = return [] +ifelse (Section n "if" cond thenpart + :Section _ "else" as elsepart:fs) + | null cond = syntaxError n "'if' with missing condition" + | null thenpart = syntaxError n "'then' branch of 'if' is empty" + | not (null as) = syntaxError n "'else' takes no arguments" + | null elsepart = syntaxError n "'else' branch of 'if' is empty" + | otherwise = do tp <- ifelse thenpart + ep <- ifelse elsepart + fs' <- ifelse fs + return (IfBlock n cond tp ep:fs') +ifelse (Section n "if" cond thenpart:fs) + | null cond = syntaxError n "'if' with missing condition" + | null thenpart = syntaxError n "'then' branch of 'if' is empty" + | otherwise = do tp <- ifelse thenpart + fs' <- ifelse fs + return (IfBlock n cond tp []:fs') +ifelse (Section n "else" _ _:_) = syntaxError n + "stray 'else' with no preceding 'if'" +ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs' + fs''' <- ifelse fs + return (Section n s a fs'' : fs''') +ifelse (f:fs) = do fs' <- ifelse fs + return (f : fs') + +------------------------------------------------------------------------------ + +-- |parse a module name +parseModuleNameQ :: ReadP r ModuleName +parseModuleNameQ = parseMaybeQuoted parse + +parseFilePathQ :: ReadP r FilePath +parseFilePathQ = parseTokenQ + -- removed until normalise is no longer broken, was: + -- liftM normalise parseTokenQ + +betweenSpaces :: ReadP r a -> ReadP r a +betweenSpaces act = do skipSpaces + res <- act + skipSpaces + return res + +parseOptVersion :: ReadP r Version +parseOptVersion = parseMaybeQuoted ver + where ver :: ReadP r Version + ver = parse <++ return nullVersion + +-- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a +-- because the "compat" version of ReadP isn't quite powerful enough. In +-- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a +-- Hence the trick above to make 'lic' polymorphic. + +-- Different than the naive version. it turns out Read instance for String accepts +-- the ['a', 'b'] syntax, which we do not want. In particular it messes +-- up any token starting with []. +parseHaskellString :: ReadP r String +parseHaskellString = + readS_to_P $ + Read.readPrec_to_S (do Read.String s <- Read.lexP; return s) 0 + +parseTokenQ :: ReadP r String +parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') + +parseTokenQ' :: ReadP r String +parseTokenQ' = parseHaskellString <++ munch1 (not . isSpace) + +parseSepList :: ReadP r b + -> ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseSepList sepr p = sepBy p separator + where separator = betweenSpaces sepr + +parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseSpaceList p = sepBy p skipSpaces + +parseCommaList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseCommaList = parseSepList (ReadP.char ',') + +-- This version avoid parse ambiguity for list element parsers +-- that have multiple valid parses of prefixes. +parseOptCommaList :: ReadP r a -> ReadP r [a] +parseOptCommaList p = sepBy p localSep + where + -- The separator must not be empty or it introduces ambiguity + localSep = (skipSpaces >> char ',' >> skipSpaces) + +++ (satisfy isSpace >> skipSpaces) + +parseQuoted :: ReadP r a -> ReadP r a +parseQuoted = between (ReadP.char '"') (ReadP.char '"') + +parseMaybeQuoted :: (forall r. ReadP r a) -> ReadP r' a +parseMaybeQuoted p = parseQuoted p <++ p + +parseFreeText :: ReadP.ReadP s String +parseFreeText = ReadP.munch (const True) + +readPToMaybe :: ReadP a a -> String -> Maybe a +readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str + , all isSpace s ] + +ppField :: String -> Doc -> Doc +ppField name fielddoc + | isEmpty fielddoc = mempty + | name `elem` nestedFields = text name <<>> colon $+$ nest indentWith fielddoc + | otherwise = text name <<>> colon <+> fielddoc + where + indentWith = 4 + nestedFields = + [ "description" + , "build-depends" + , "data-files" + , "extra-source-files" + , "extra-tmp-files" + , "exposed-modules" + , "asm-sources" + , "cmm-sources" + , "c-sources" + , "js-sources" + , "extra-libraries" + , "includes" + , "install-includes" + , "other-modules" + , "autogen-modules" + , "depends" + ] + +parseFlagAssignment :: ReadP r FlagAssignment +parseFlagAssignment = mkFlagAssignment <$> + sepBy parseFlagValue skipSpaces1 + where + parseFlagValue = + (do optional (char '+') + f <- parse + return (f, True)) + +++ (do _ <- char '-' + f <- parse + return (f, False)) + +------------------------------------------------------------------------------- +-- Internal +------------------------------------------------------------------------------- + +showTestedWith :: (CompilerFlavor, VersionRange) -> Doc +showTestedWith = pretty . pack' TestedWith diff --git a/Distribution/Deprecated/ReadP.hs b/Distribution/Deprecated/ReadP.hs new file mode 100644 --- /dev/null +++ b/Distribution/Deprecated/ReadP.hs @@ -0,0 +1,480 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +----------------------------------------------------------------------------- +-- | +-- +-- Module : Distribution.Deprecated.ReadP +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This is a library of parser combinators, originally written by Koen Claessen. +-- It parses all alternatives in parallel, so it never keeps hold of +-- the beginning of the input string, a common source of space leaks with +-- other parsers. The '(+++)' choice combinator is genuinely commutative; +-- it makes no difference which branch is \"shorter\". +-- +-- See also Koen's paper /Parallel Parsing Processes/ +-- (). +-- +-- This version of ReadP has been locally hacked to make it H98, by +-- Martin Sjögren +-- +-- The unit tests have been moved to UnitTest.Distribution.Deprecated.ReadP, by +-- Mark Lentczner +----------------------------------------------------------------------------- + +module Distribution.Deprecated.ReadP + ( + -- * The 'ReadP' type + ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus + + -- * Primitive operations + get, -- :: ReadP Char + look, -- :: ReadP String + (+++), -- :: ReadP a -> ReadP a -> ReadP a + (<++), -- :: ReadP a -> ReadP a -> ReadP a + gather, -- :: ReadP a -> ReadP (String, a) + + -- * Other operations + pfail, -- :: ReadP a + eof, -- :: ReadP () + satisfy, -- :: (Char -> Bool) -> ReadP Char + char, -- :: Char -> ReadP Char + string, -- :: String -> ReadP String + munch, -- :: (Char -> Bool) -> ReadP String + munch1, -- :: (Char -> Bool) -> ReadP String + skipSpaces, -- :: ReadP () + skipSpaces1,-- :: ReadP () + choice, -- :: [ReadP a] -> ReadP a + count, -- :: Int -> ReadP a -> ReadP [a] + between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a + option, -- :: a -> ReadP a -> ReadP a + optional, -- :: ReadP a -> ReadP () + many, -- :: ReadP a -> ReadP [a] + many1, -- :: ReadP a -> ReadP [a] + skipMany, -- :: ReadP a -> ReadP () + skipMany1, -- :: ReadP a -> ReadP () + sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a] + sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] + endBy, -- :: ReadP a -> ReadP sep -> ReadP [a] + endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] + chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a + chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a + chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a + chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a + manyTill, -- :: ReadP a -> ReadP end -> ReadP [a] + + -- * Running a parser + ReadS, -- :: *; = String -> [(a,String)] + readP_to_S, -- :: ReadP a -> ReadS a + readS_to_P, -- :: ReadS a -> ReadP a + readP_to_E, + + -- ** Internal + Parser, + ) + where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (many, get) + +import Control.Monad( replicateM, (>=>) ) + +import qualified Control.Monad.Fail as Fail + +import Distribution.CabalSpecVersion (cabalSpecLatest) +import qualified Distribution.Compat.CharParsing as P +import qualified Distribution.Parsec as P + +import Distribution.ReadE (ReadE (..)) + +infixr 5 +++, <++ + +-- --------------------------------------------------------------------------- +-- The P type +-- is representation type -- should be kept abstract + +data P s a + = Get (s -> P s a) + | Look ([s] -> P s a) + | Fail + | Result a (P s a) + | Final [(a,[s])] -- invariant: list is non-empty! + +-- Monad, MonadPlus + +instance Functor (P s) where + fmap = liftM + +instance Applicative (P s) where + pure x = Result x Fail + (<*>) = ap + +instance Monad (P s) where + return = pure + + (Get f) >>= k = Get (f >=> k) + (Look f) >>= k = Look (f >=> k) + Fail >>= _ = Fail + (Result x p) >>= k = k x `mplus` (p >>= k) + (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s] + +#if !(MIN_VERSION_base(4,9,0)) + fail _ = Fail +#elif !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif + +instance Fail.MonadFail (P s) where + fail _ = Fail + +instance Alternative (P s) where + empty = mzero + (<|>) = mplus + +instance MonadPlus (P s) where + mzero = Fail + + -- most common case: two gets are combined + Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c) + + -- results are delivered as soon as possible + Result x p `mplus` q = Result x (p `mplus` q) + p `mplus` Result x q = Result x (p `mplus` q) + + -- fail disappears + Fail `mplus` p = p + p `mplus` Fail = p + + -- two finals are combined + -- final + look becomes one look and one final (=optimization) + -- final + sthg else becomes one look and one final + Final r `mplus` Final t = Final (r ++ t) + Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s)) + Final r `mplus` p = Look (\s -> Final (r ++ run p s)) + Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r)) + p `mplus` Final r = Look (\s -> Final (run p s ++ r)) + + -- two looks are combined (=optimization) + -- look + sthg else floats upwards + Look f `mplus` Look g = Look (\s -> f s `mplus` g s) + Look f `mplus` p = Look (\s -> f s `mplus` p) + p `mplus` Look f = Look (\s -> p `mplus` f s) + +-- --------------------------------------------------------------------------- +-- The ReadP type + +newtype Parser r s a = R ((a -> P s r) -> P s r) +type ReadP r a = Parser r Char a + +-- Functor, Monad, MonadPlus + +instance Functor (Parser r s) where + fmap h (R f) = R (\k -> f (k . h)) + +instance Applicative (Parser r s) where + pure x = R (\k -> k x) + (<*>) = ap + +instance s ~ Char => Alternative (Parser r s) where + empty = pfail + (<|>) = (+++) + +instance Monad (Parser r s) where + return = pure + R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) + +#if !(MIN_VERSION_base(4,9,0)) + fail _ = R (const Fail) +#elif !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif + +instance Fail.MonadFail (Parser r s) where + fail _ = R (const Fail) + +instance s ~ Char => MonadPlus (Parser r s) where + mzero = pfail + mplus = (+++) + +-- --------------------------------------------------------------------------- +-- Operations over P + +final :: [(a,[s])] -> P s a +-- Maintains invariant for Final constructor +final [] = Fail +final r = Final r + +run :: P c a -> ([c] -> [(a, [c])]) +run (Get f) (c:s) = run (f c) s +run (Look f) s = run (f s) s +run (Result x p) s = (x,s) : run p s +run (Final r) _ = r +run _ _ = [] + +-- --------------------------------------------------------------------------- +-- Operations over ReadP + +get :: ReadP r Char +-- ^ Consumes and returns the next character. +-- Fails if there is no input left. +get = R Get + +look :: ReadP r String +-- ^ Look-ahead: returns the part of the input that is left, without +-- consuming it. +look = R Look + +pfail :: ReadP r a +-- ^ Always fails. +pfail = R (const Fail) + +eof :: ReadP r () +-- ^ Succeeds iff we are at the end of input +eof = do { s <- look + ; if null s then return () + else pfail } + +(+++) :: ReadP r a -> ReadP r a -> ReadP r a +-- ^ Symmetric choice. +R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k) + +(<++) :: ReadP a a -> ReadP r a -> ReadP r a +-- ^ Local, exclusive, left-biased choice: If left parser +-- locally produces any result at all, then right parser is +-- not used. +R f <++ q = + do s <- look + probe (f return) s 0 + where + probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int) + probe (Look f') s n = probe (f' s) s n + probe p@(Result _ _) _ n = discard n >> R (p >>=) + probe (Final r) _ _ = R (Final r >>=) + probe _ _ _ = q + + discard 0 = return () + discard n = get >> discard (n-1 :: Int) + +gather :: ReadP (String -> P Char r) a -> ReadP r (String, a) +-- ^ Transforms a parser into one that does the same, but +-- in addition returns the exact characters read. +-- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument +-- is built using any occurrences of readS_to_P. +gather (R m) = + R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) + where + gath l (Get f) = Get (\c -> gath (l.(c:)) (f c)) + gath _ Fail = Fail + gath l (Look f) = Look (gath l . f) + gath l (Result k p) = k (l []) `mplus` gath l p + gath _ (Final _) = error "do not use readS_to_P in gather!" + +-- --------------------------------------------------------------------------- +-- Derived operations + +satisfy :: (Char -> Bool) -> ReadP r Char +-- ^ Consumes and returns the next character, if it satisfies the +-- specified predicate. +satisfy p = do c <- get; if p c then return c else pfail + +char :: Char -> ReadP r Char +-- ^ Parses and returns the specified character. +char c = satisfy (c ==) + +string :: String -> ReadP r String +-- ^ Parses and returns the specified string. +string this = do s <- look; scan this s + where + scan [] _ = return this + scan (x:xs) (y:ys) | x == y = get >> scan xs ys + scan _ _ = pfail + +munch :: (Char -> Bool) -> ReadP r String +-- ^ Parses the first zero or more characters satisfying the predicate. +munch p = + do s <- look + scan s + where + scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s) + scan _ = do return "" + +munch1 :: (Char -> Bool) -> ReadP r String +-- ^ Parses the first one or more characters satisfying the predicate. +munch1 p = + do c <- get + if p c then do s <- munch p; return (c:s) + else pfail + +choice :: [ReadP r a] -> ReadP r a +-- ^ Combines all parsers in the specified list. +choice [] = pfail +choice [p] = p +choice (p:ps) = p +++ choice ps + +skipSpaces :: ReadP r () +-- ^ Skips all whitespace. +skipSpaces = + do s <- look + skip s + where + skip (c:s) | isSpace c = do _ <- get; skip s + skip _ = do return () + +skipSpaces1 :: ReadP r () +-- ^ Like 'skipSpaces' but succeeds only if there is at least one +-- whitespace character to skip. +skipSpaces1 = satisfy isSpace >> skipSpaces + +count :: Int -> ReadP r a -> ReadP r [a] +-- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of +-- results is returned. +count n p = replicateM n p + +between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a +-- ^ @ between open close p @ parses @open@, followed by @p@ and finally +-- @close@. Only the value of @p@ is returned. +between open close p = do _ <- open + x <- p + _ <- close + return x + +option :: a -> ReadP r a -> ReadP r a +-- ^ @option x p@ will either parse @p@ or return @x@ without consuming +-- any input. +option x p = p +++ return x + +optional :: ReadP r a -> ReadP r () +-- ^ @optional p@ optionally parses @p@ and always returns @()@. +optional p = (p >> return ()) +++ return () + +many :: ReadP r a -> ReadP r [a] +-- ^ Parses zero or more occurrences of the given parser. +many p = return [] +++ many1 p + +many1 :: ReadP r a -> ReadP r [a] +-- ^ Parses one or more occurrences of the given parser. +many1 p = liftM2 (:) p (many p) + +skipMany :: ReadP r a -> ReadP r () +-- ^ Like 'many', but discards the result. +skipMany p = many p >> return () + +skipMany1 :: ReadP r a -> ReadP r () +-- ^ Like 'many1', but discards the result. +skipMany1 p = p >> skipMany p + +sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@. +-- Returns a list of values returned by @p@. +sepBy p sep = sepBy1 p sep +++ return [] + +sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@. +-- Returns a list of values returned by @p@. +sepBy1 p sep = liftM2 (:) p (many (sep >> p)) + +endBy :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended +-- by @sep@. +endBy p sep = many (do x <- p ; _ <- sep ; return x) + +endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended +-- by @sep@. +endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x) + +chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a +-- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. +-- Returns a value produced by a /right/ associative application of all +-- functions returned by @op@. If there are no occurrences of @p@, @x@ is +-- returned. +chainr p op x = chainr1 p op +++ return x + +chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a +-- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@. +-- Returns a value produced by a /left/ associative application of all +-- functions returned by @op@. If there are no occurrences of @p@, @x@ is +-- returned. +chainl p op x = chainl1 p op +++ return x + +chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a +-- ^ Like 'chainr', but parses one or more occurrences of @p@. +chainr1 p op = scan + where scan = p >>= rest + rest x = do f <- op + y <- scan + return (f x y) + +++ return x + +chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a +-- ^ Like 'chainl', but parses one or more occurrences of @p@. +chainl1 p op = p >>= rest + where rest x = do f <- op + y <- p + rest (f x y) + +++ return x + +manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a] +-- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@ +-- succeeds. Returns a list of values returned by @p@. +manyTill p end = scan + where scan = (end >> return []) <++ (liftM2 (:) p scan) + +-- --------------------------------------------------------------------------- +-- Converting between ReadP and Read + +readP_to_S :: ReadP a a -> ReadS a +-- ^ Converts a parser into a Haskell ReadS-style function. +-- This is the main way in which you can \"run\" a 'ReadP' parser: +-- the expanded type is +-- @ readP_to_S :: ReadP a -> String -> [(a,String)] @ +readP_to_S (R f) = run (f return) + +readS_to_P :: ReadS a -> ReadP r a +-- ^ Converts a Haskell ReadS-style function into a parser. +-- Warning: This introduces local backtracking in the resulting +-- parser, and therefore a possible inefficiency. +readS_to_P r = + R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s'])) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +instance t ~ Char => P.Parsing (Parser r t) where + try = id + () = const + skipMany = skipMany + skipSome = skipMany1 + unexpected = const pfail + eof = eof + + -- TODO: we would like to have <++ here + notFollowedBy p = ((Just <$> p) +++ pure Nothing) + >>= maybe (pure ()) (P.unexpected . show) + +instance t ~ Char => P.CharParsing (Parser r t) where + satisfy = satisfy + char = char + notChar c = satisfy (/= c) + anyChar = get + string = string + +instance t ~ Char => P.CabalParsing (Parser r t) where + parsecWarning _ _ = pure () + askCabalSpecVersion = pure cabalSpecLatest + +------------------------------------------------------------------------------- +-- ReadE +------------------------------------------------------------------------------- + +readP_to_E :: (String -> String) -> ReadP a a -> ReadE a +readP_to_E err r = + ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt + , all isSpace s ] + of [] -> Left (err txt) + (p:_) -> Right p diff --git a/Distribution/Deprecated/Text.hs b/Distribution/Deprecated/Text.hs new file mode 100644 --- /dev/null +++ b/Distribution/Deprecated/Text.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE DefaultSignatures #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Deprecated.Text +-- Copyright : Duncan Coutts 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- classes. The difference is that it uses a modern pretty printer and parser +-- system and the format is not expected to be Haskell concrete syntax but +-- rather the external human readable representation used by Cabal. +-- +module Distribution.Deprecated.Text ( + Text(..), + defaultStyle, + display, + flatStyle, + simpleParse, + stdParse, + -- parse utils + parsePackageName, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude (read) + +import Distribution.Deprecated.ReadP ((<++)) +import qualified Distribution.Deprecated.ReadP as Parse + +import Data.Functor.Identity (Identity (..)) +import Distribution.Parsec +import Distribution.Pretty +import qualified Text.PrettyPrint as Disp + +import qualified Data.Set as Set + +import Data.Version (Version (Version)) + +import qualified Distribution.Compiler as D +import qualified Distribution.License as D +import qualified Distribution.ModuleName as D +import qualified Distribution.Package as D +import qualified Distribution.PackageDescription as D +import qualified Distribution.Simple.Setup as D +import qualified Distribution.System as D +import qualified Distribution.Types.PackageVersionConstraint as D +import qualified Distribution.Types.SourceRepo as D +import qualified Distribution.Types.UnqualComponentName as D +import qualified Distribution.Version as D +import qualified Distribution.Types.VersionRange.Internal as D +import qualified Language.Haskell.Extension as E + +-- | /Note:/ this class will soon be deprecated. +-- It's not yet, so that we are @-Wall@ clean. +class Text a where + disp :: a -> Disp.Doc + default disp :: Pretty a => a -> Disp.Doc + disp = pretty + + parse :: Parse.ReadP r a + default parse :: Parsec a => Parse.ReadP r a + parse = parsec + +-- | Pretty-prints with the default style. +display :: Text a => a -> String +display = Disp.renderStyle defaultStyle . disp + +simpleParse :: Text a => String -> Maybe a +simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str + , all isSpace s ] of + [] -> Nothing + (p:_) -> Just p + +stdParse :: Text ver => (ver -> String -> res) -> Parse.ReadP r res +stdParse f = do + cs <- Parse.sepBy1 component (Parse.char '-') + _ <- Parse.char '-' + ver <- parse + let name = intercalate "-" cs + return $! f ver (lowercase name) + where + component = do + cs <- Parse.munch1 isAlphaNum + if all isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +lowercase :: String -> String +lowercase = map toLower + +-- ----------------------------------------------------------------------------- +-- Instances for types from the base package + +instance Text Bool where + parse = Parse.choice [ (Parse.string "True" Parse.+++ + Parse.string "true") >> return True + , (Parse.string "False" Parse.+++ + Parse.string "false") >> return False ] + +instance Text Int where + parse = fmap negate (Parse.char '-' >> parseNat) Parse.+++ parseNat + +instance Text a => Text (Identity a) where + disp = disp . runIdentity + parse = fmap Identity parse + +-- | Parser for non-negative integers. +parseNat :: Parse.ReadP r Int +parseNat = read `fmap` Parse.munch1 isDigit -- TODO: eradicateNoParse + + +instance Text Version where + disp (Version branch _tags) -- Death to version tags!! + = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch)) + + parse = do + branch <- Parse.sepBy1 parseNat (Parse.char '.') + -- allow but ignore tags: + _tags <- Parse.many (Parse.char '-' >> Parse.munch1 isAlphaNum) + return (Version branch []) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +instance Text D.Arch where + parse = fmap (D.classifyArch D.Strict) ident + +instance Text D.BuildType where + parse = do + name <- Parse.munch1 isAlphaNum + case name of + "Simple" -> return D.Simple + "Configure" -> return D.Configure + "Custom" -> return D.Custom + "Make" -> return D.Make + "Default" -> return D.Custom + _ -> fail ("unknown build-type: '" ++ name ++ "'") + +instance Text D.CompilerFlavor where + parse = do + comp <- Parse.munch1 isAlphaNum + when (all isDigit comp) Parse.pfail + return (D.classifyCompilerFlavor comp) + +instance Text D.CompilerId where + parse = do + flavour <- parse + version <- (Parse.char '-' >> parse) Parse.<++ return D.nullVersion + return (D.CompilerId flavour version) + +instance Text D.ComponentId where + parse = D.mkComponentId `fmap` Parse.munch1 abi_char + where abi_char c = isAlphaNum c || c `elem` "-_." + +instance Text D.DefUnitId where + parse = D.unsafeMkDefUnitId `fmap` parse + +instance Text D.UnitId where + parse = D.mkUnitId <$> Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") + +instance Text D.Dependency where + parse = do name <- parse + Parse.skipSpaces + libs <- Parse.option [D.LMainLibName] + $ (Parse.char ':' *>) + $ pure <$> parseLib name <|> parseMultipleLibs name + Parse.skipSpaces + ver <- parse Parse.<++ return D.anyVersion + Parse.skipSpaces + return $ D.Dependency name ver $ Set.fromList libs + where makeLib pn ln | D.unPackageName pn == ln = D.LMainLibName + | otherwise = D.LSubLibName $ D.mkUnqualComponentName ln + parseLib pn = makeLib pn <$> parsecUnqualComponentName + parseMultipleLibs pn = Parse.between (Parse.char '{' *> Parse.skipSpaces) + (Parse.skipSpaces <* Parse.char '}') + $ parsecCommaList $ parseLib pn + + +instance Text E.Extension where + parse = do + extension <- Parse.munch1 isAlphaNum + return (E.classifyExtension extension) + +instance Text D.FlagName where + -- Note: we don't check that FlagName doesn't have leading dash, + -- cabal check will do that. + parse = D.mkFlagName . lowercase <$> parse' + where + parse' = (:) <$> lead <*> rest + lead = Parse.satisfy (\c -> isAlphaNum c || c == '_') + rest = Parse.munch (\c -> isAlphaNum c || c == '_' || c == '-') + +instance Text D.HaddockTarget where + parse = Parse.choice [ Parse.string "for-hackage" >> return D.ForHackage + , Parse.string "for-development" >> return D.ForDevelopment] + +instance Text E.Language where + parse = do + lang <- Parse.munch1 isAlphaNum + return (E.classifyLanguage lang) + +instance Text D.License where + parse = do + name <- Parse.munch1 (\c -> isAlphaNum c && c /= '-') + version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse) + return $! case (name, version :: Maybe D.Version) of + ("GPL", _ ) -> D.GPL version + ("LGPL", _ ) -> D.LGPL version + ("AGPL", _ ) -> D.AGPL version + ("BSD2", Nothing) -> D.BSD2 + ("BSD3", Nothing) -> D.BSD3 + ("BSD4", Nothing) -> D.BSD4 + ("ISC", Nothing) -> D.ISC + ("MIT", Nothing) -> D.MIT + ("MPL", Just version') -> D.MPL version' + ("Apache", _ ) -> D.Apache version + ("PublicDomain", Nothing) -> D.PublicDomain + ("AllRightsReserved", Nothing) -> D.AllRightsReserved + ("OtherLicense", Nothing) -> D.OtherLicense + _ -> D.UnknownLicense $ name ++ + maybe "" (('-':) . display) version + +instance Text D.Module where + parse = do + uid <- parse + _ <- Parse.char ':' + mod_name <- parse + return (D.Module uid mod_name) + +instance Text D.ModuleName where + parse = do + ms <- Parse.sepBy1 component (Parse.char '.') + return (D.fromComponents ms) + + where + component = do + c <- Parse.satisfy isUpper + cs <- Parse.munch validModuleChar + return (c:cs) + +instance Text D.OS where + parse = fmap (D.classifyOS D.Compat) ident + +instance Text D.PackageVersionConstraint where + parse = do name <- parse + Parse.skipSpaces + ver <- parse Parse.<++ return D.anyVersion + Parse.skipSpaces + return (D.PackageVersionConstraint name ver) + +instance Text D.PkgconfigName where + parse = D.mkPkgconfigName + <$> Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-._") + +instance Text D.Platform where + -- TODO: there are ambigious platforms like: `arch-word-os` + -- which could be parsed as + -- * Platform "arch-word" "os" + -- * Platform "arch" "word-os" + -- We could support that preferring variants 'OtherOS' or 'OtherArch' + -- + -- For now we split into arch and os parts on the first dash. + parse = do + arch <- parseDashlessArch + _ <- Parse.char '-' + os <- parse + return (D.Platform arch os) + where + parseDashlessArch :: Parse.ReadP r D.Arch + parseDashlessArch = fmap (D.classifyArch D.Strict) dashlessIdent + + dashlessIdent :: Parse.ReadP r String + dashlessIdent = liftM2 (:) firstChar rest + where firstChar = Parse.satisfy isAlpha + rest = Parse.munch (\c -> isAlphaNum c || c == '_') + +instance Text D.RepoKind where + parse = fmap D.classifyRepoKind ident + +instance Text D.RepoType where + parse = fmap D.classifyRepoType ident + +instance Text D.UnqualComponentName where + parse = D.mkUnqualComponentName <$> parsePackageName + +instance Text D.PackageIdentifier where + parse = do + n <- parse + v <- (Parse.char '-' >> parse) <++ return D.nullVersion + return (D.PackageIdentifier n v) + +instance Text D.PackageName where + parse = D.mkPackageName <$> parsePackageName + +instance Text D.Version where + parse = do + branch <- Parse.sepBy1 parseNat (Parse.char '.') + -- allow but ignore tags: + _tags <- Parse.many (Parse.char '-' >> Parse.munch1 isAlphaNum) + return (D.mkVersion branch) + +instance Text D.VersionRange where + parse = expr + where + expr = do Parse.skipSpaces + t <- term + Parse.skipSpaces + (do _ <- Parse.string "||" + Parse.skipSpaces + e <- expr + return (D.unionVersionRanges t e) + Parse.+++ + return t) + term = do f <- factor + Parse.skipSpaces + (do _ <- Parse.string "&&" + Parse.skipSpaces + t <- term + return (D.intersectVersionRanges f t) + Parse.+++ + return f) + factor = Parse.choice $ parens expr + : parseAnyVersion + : parseNoVersion + : parseWildcardRange + : map parseRangeOp rangeOps + parseAnyVersion = Parse.string "-any" >> return D.anyVersion + parseNoVersion = Parse.string "-none" >> return D.noVersion + + parseWildcardRange = do + _ <- Parse.string "==" + Parse.skipSpaces + branch <- Parse.sepBy1 digits (Parse.char '.') + _ <- Parse.char '.' + _ <- Parse.char '*' + return (D.withinVersion (D.mkVersion branch)) + + parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces) + (Parse.char ')' >> Parse.skipSpaces) + (do a <- p + Parse.skipSpaces + return (D.VersionRangeParens a)) + digits = do + firstDigit <- Parse.satisfy isDigit + if firstDigit == '0' + then return 0 + else do rest <- Parse.munch isDigit + return (read (firstDigit : rest)) -- TODO: eradicateNoParse + + parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse + rangeOps = [ ("<", D.earlierVersion), + ("<=", D.orEarlierVersion), + (">", D.laterVersion), + (">=", D.orLaterVersion), + ("^>=", D.majorBoundVersion), + ("==", D.thisVersion) ] + +------------------------------------------------------------------------------- +-- ParseUtils +------------------------------------------------------------------------------- + +parsePackageName :: Parse.ReadP r String +parsePackageName = do + ns <- Parse.sepBy1 component (Parse.char '-') + return $ intercalate "-" ns + where + component = do + cs <- Parse.munch1 isAlphaNum + if all isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + + +ident :: Parse.ReadP r String +ident = liftM2 (:) firstChar rest + where firstChar = Parse.satisfy isAlpha + rest = Parse.munch (\c -> isAlphaNum c || c == '_' || c == '-') + +validModuleChar :: Char -> Bool +validModuleChar c = isAlphaNum c || c == '_' || c == '\'' + +------------------------------------------------------------------------------- +-- Rest of instances, we don't seem to need +------------------------------------------------------------------------------- + +-- instance Text D.AbiDependency +-- instance Text D.AbiHash +-- instance Text D.AbiTa +-- instance Text D.BenchmarkType +-- instance Text D.ExecutableScope +-- instance Text D.ExeDependency +-- instance Text D.ExposedModule +-- instance Text D.ForeignLibOption +-- instance Text D.ForeignLibType +-- instance Text D.IncludeRenaming +-- instance Text D.KnownExtension +-- instance Text D.LegacyExeDependency +-- instance Text D.LibVersionInfo +-- instance Text D.License +-- instance Text D.Mixin +-- instance Text D.ModuleReexport +-- instance Text D.ModuleRenaming +-- instance Text D.MungedPackageName +-- instance Text D.OpenModule +-- instance Text D.OpenUnitId +-- instance Text D.PackageVersionConstraint +-- instance Text D.PkgconfigDependency +-- instance Text D.TestType diff --git a/Distribution/Deprecated/ViewAsFieldDescr.hs b/Distribution/Deprecated/ViewAsFieldDescr.hs new file mode 100644 --- /dev/null +++ b/Distribution/Deprecated/ViewAsFieldDescr.hs @@ -0,0 +1,85 @@ +module Distribution.Deprecated.ViewAsFieldDescr ( + viewAsFieldDescr + ) where + +import Distribution.Client.Compat.Prelude hiding (get) +import Prelude () + +import Distribution.Parsec (parsec) +import Distribution.Pretty +import Distribution.ReadE (parsecToReadE) +import Distribution.Simple.Command +import Text.PrettyPrint (cat, comma, punctuate, text) +import Text.PrettyPrint as PP (empty) + +import Distribution.Deprecated.ParseUtils (FieldDescr (..), runE, syntaxError) + +-- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > +-- Choice > Opt) and consider only the first one. +viewAsFieldDescr :: OptionField a -> FieldDescr a +viewAsFieldDescr (OptionField _n []) = + error "Distribution.command.viewAsFieldDescr: unexpected" +viewAsFieldDescr (OptionField n dd) = FieldDescr n get set + + where + optDescr = head $ sortBy cmp dd + + cmp :: OptDescr a -> OptDescr a -> Ordering + ReqArg{} `cmp` ReqArg{} = EQ + ReqArg{} `cmp` _ = GT + BoolOpt{} `cmp` ReqArg{} = LT + BoolOpt{} `cmp` BoolOpt{} = EQ + BoolOpt{} `cmp` _ = GT + ChoiceOpt{} `cmp` ReqArg{} = LT + ChoiceOpt{} `cmp` BoolOpt{} = LT + ChoiceOpt{} `cmp` ChoiceOpt{} = EQ + ChoiceOpt{} `cmp` _ = GT + OptArg{} `cmp` OptArg{} = EQ + OptArg{} `cmp` _ = LT + +-- get :: a -> Doc + get t = case optDescr of + ReqArg _ _ _ _ ppr -> + (cat . punctuate comma . map text . ppr) t + + OptArg _ _ _ _ _ ppr -> + case ppr t of [] -> PP.empty + (Nothing : _) -> text "True" + (Just a : _) -> text a + + ChoiceOpt alts -> + fromMaybe PP.empty $ listToMaybe + [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t] + + BoolOpt _ _ _ _ enabled -> (maybe PP.empty pretty . enabled) t + +-- set :: LineNo -> String -> a -> ParseResult a + set line val a = + case optDescr of + ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val + -- We parse for a single value instead of a + -- list, as one can't really implement + -- parseList :: ReadE a -> ReadE [a] with + -- the current ReadE definition + ChoiceOpt{} -> + case getChoiceByLongFlag optDescr val of + Just f -> return (f a) + _ -> syntaxError line val + + BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runE line n (parsecToReadE ("" ++) parsec) val + + OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val + -- Optional arguments are parsed just like + -- required arguments here; we don't + -- provide a method to set an OptArg field + -- to the default value. + +getChoiceByLongFlag :: OptDescr a -> String -> Maybe (a -> a) +getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe + [ set | (_,(_sf,lf:_), set, _) <- alts + , lf == val] + +getChoiceByLongFlag _ _ = + error "Distribution.command.getChoiceByLongFlag: expected a choice option" + + diff --git a/Distribution/Solver/Compat/Prelude.hs b/Distribution/Solver/Compat/Prelude.hs --- a/Distribution/Solver/Compat/Prelude.hs +++ b/Distribution/Solver/Compat/Prelude.hs @@ -3,7 +3,7 @@ -- | This module does two things: -- --- * Acts as a compatiblity layer, like @base-compat@. +-- * Acts as a compatibility layer, like @base-compat@. -- -- * Provides commonly used imports. -- diff --git a/Distribution/Solver/Modular.hs b/Distribution/Solver/Modular.hs --- a/Distribution/Solver/Modular.hs +++ b/Distribution/Solver/Modular.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Distribution.Solver.Modular - ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..)) where + ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) where -- Here, we try to map between the external cabal-install solver -- interface and the internal interface that the solver actually @@ -13,7 +16,7 @@ import Distribution.Solver.Compat.Prelude import qualified Data.Map as M -import Data.Set (Set) +import Data.Set (Set, isSubsetOf) import Data.Ord import Distribution.Compat.Graph ( IsNode(..) ) @@ -30,9 +33,10 @@ import Distribution.Solver.Modular.IndexConversion ( convPIs ) import Distribution.Solver.Modular.Log - ( SolverFailure(..), logToProgress ) + ( SolverFailure(..), displayLogMessages ) import Distribution.Solver.Modular.Package ( PN ) +import Distribution.Solver.Modular.RetryLog import Distribution.Solver.Modular.Solver ( SolverConfig(..), PruneAfterFirstSuccess(..), solve ) import Distribution.Solver.Types.DependencyResolver @@ -46,6 +50,8 @@ import Distribution.Solver.Types.Variable import Distribution.System ( Platform(..) ) +import Distribution.Simple.Setup + ( BooleanFlag(..) ) import Distribution.Simple.Utils ( ordNubBy ) import Distribution.Verbosity @@ -80,16 +86,17 @@ -- -- When there is no solution, we produce the error message by rerunning the -- solver but making it prefer the goals from the final conflict set from the --- first run. We also set the backjump limit to 0, so that the log stops at the --- first backjump and is relatively short. Preferring goals from the final --- conflict set increases the probability that the log to the first backjump --- contains package, flag, and stanza choices that are relevant to the final --- failure. The solver shouldn't need to choose any packages that aren't in the --- final conflict set. (For every variable in the final conflict set, the final --- conflict set should also contain the variable that introduced that variable. --- The solver can then follow that chain of variables in reverse order from the --- user target to the conflict.) However, it is possible that the conflict set --- contains unnecessary variables. +-- first run (or a subset of the final conflict set with +-- --minimize-conflict-set). We also set the backjump limit to 0, so that the +-- log stops at the first backjump and is relatively short. Preferring goals +-- from the final conflict set increases the probability that the log to the +-- first backjump contains package, flag, and stanza choices that are relevant +-- to the final failure. The solver shouldn't need to choose any packages that +-- aren't in the final conflict set. (For every variable in the final conflict +-- set, the final conflict set should also contain the variable that introduced +-- that variable. The solver can then follow that chain of variables in reverse +-- order from the user target to the conflict.) However, it is possible that the +-- conflict set contains unnecessary variables. -- -- Producing an error message when the solver reaches the backjump limit is more -- complicated. There is no final conflict set, so we create one for the minimal @@ -116,33 +123,53 @@ -> Set PN -> Progress String String (Assignment, RevDepMap) solve' sc cinfo idx pkgConfigDB pprefs gcs pns = - foldProgress Step (uncurry createErrorMsg) Done (runSolver printFullLog sc) + toProgress $ retry (runSolver printFullLog sc) createErrorMsg where runSolver :: Bool -> SolverConfig - -> Progress String (SolverFailure, String) (Assignment, RevDepMap) + -> RetryLog String SolverFailure (Assignment, RevDepMap) runSolver keepLog sc' = - logToProgress keepLog (solverVerbosity sc') (maxBackjumps sc') $ + displayLogMessages keepLog $ solve sc' cinfo idx pkgConfigDB pprefs gcs pns - createErrorMsg :: SolverFailure -> String - -> Progress String String (Assignment, RevDepMap) - createErrorMsg (ExhaustiveSearch cs _) msg = - Fail $ rerunSolverForErrorMsg cs ++ msg - createErrorMsg BackjumpLimitReached msg = - Step ("Backjump limit reached. Rerunning dependency solver to generate " + createErrorMsg :: SolverFailure + -> RetryLog String String (Assignment, RevDepMap) + createErrorMsg failure@(ExhaustiveSearch cs cm) = + if asBool $ minimizeConflictSet sc + then continueWith ("Found no solution after exhaustively searching the " + ++ "dependency tree. Rerunning the dependency solver " + ++ "to minimize the conflict set ({" + ++ showConflictSet cs ++ "}).") $ + retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs cm) $ + \case + ExhaustiveSearch cs' cm' -> + fromProgress $ Fail $ + rerunSolverForErrorMsg cs' + ++ finalErrorMsg sc (ExhaustiveSearch cs' cm') + BackjumpLimitReached -> + fromProgress $ Fail $ + "Reached backjump limit while trying to minimize the " + ++ "conflict set to create a better error message. " + ++ "Original error message:\n" + ++ rerunSolverForErrorMsg cs + ++ finalErrorMsg sc failure + else fromProgress $ Fail $ + rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure + createErrorMsg failure@BackjumpLimitReached = + continueWith + ("Backjump limit reached. Rerunning dependency solver to generate " ++ "a final conflict set for the search tree containing the " ++ "first backjump.") $ - foldProgress Step (f . fst) Done $ - runSolver printFullLog - sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True } - where - f :: SolverFailure -> Progress String String (Assignment, RevDepMap) - f (ExhaustiveSearch cs _) = Fail $ rerunSolverForErrorMsg cs ++ msg - f BackjumpLimitReached = - -- This case is possible when the number of goals involved in - -- conflicts is greater than the backjump limit. - Fail $ msg ++ "Failed to generate a summarized dependency solver " - ++ "log due to low backjump limit." + retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $ + \case + ExhaustiveSearch cs _ -> + fromProgress $ Fail $ + rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure + BackjumpLimitReached -> + -- This case is possible when the number of goals involved in + -- conflicts is greater than the backjump limit. + fromProgress $ Fail $ finalErrorMsg sc failure + ++ "Failed to generate a summarized dependency solver " + ++ "log due to low backjump limit." rerunSolverForErrorMsg :: ConflictSet -> String rerunSolverForErrorMsg cs = @@ -155,21 +182,158 @@ -- original goal order. goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc) - in unlines ("Could not resolve dependencies:" : messages (runSolver True sc')) + in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc'))) printFullLog = solverVerbosity sc >= verbose messages :: Progress step fail done -> [step] messages = foldProgress (:) (const []) (const []) +-- | Try to remove variables from the given conflict set to create a minimal +-- conflict set. +-- +-- Minimal means that no proper subset of the conflict set is also a conflict +-- set, though there may be other possible conflict sets with fewer variables. +-- This function minimizes the input by trying to remove one variable at a time. +-- It only makes one pass over the variables, so it runs the solver at most N +-- times when given a conflict set of size N. Only one pass is necessary, +-- because every superset of a conflict set is also a conflict set, meaning that +-- failing to remove variable X from a conflict set in one step means that X +-- cannot be removed from any subset of that conflict set in a subsequent step. +-- +-- Example steps: +-- +-- Start with {A, B, C}. +-- Try to remove A from {A, B, C} and fail. +-- Try to remove B from {A, B, C} and succeed. +-- Try to remove C from {A, C} and fail. +-- Return {A, C} +-- +-- This function can fail for two reasons: +-- +-- 1. The solver can reach the backjump limit on any run. In this case the +-- returned RetryLog ends with BackjumpLimitReached. +-- TODO: Consider applying the backjump limit to all solver runs combined, +-- instead of each individual run. For example, 10 runs with 10 backjumps +-- each should count as 100 backjumps. +-- 2. Since this function works by rerunning the solver, it is possible for the +-- solver to add new unnecessary variables to the conflict set. This function +-- discards the result from any run that adds new variables to the conflict +-- set, but the end result may not be completely minimized. +tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog String SolverFailure a) + -> SolverConfig + -> ConflictSet + -> ConflictMap + -> RetryLog String SolverFailure a +tryToMinimizeConflictSet runSolver sc cs cm = + foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v) + (fromProgress $ Fail $ ExhaustiveSearch cs cm) + (CS.toList cs) + where + -- This function runs the solver and makes it prefer goals in the following + -- order: + -- + -- 1. variables in 'smallestKnownCS', excluding 'v' + -- 2. 'v' + -- 3. all other variables + -- + -- If 'v' is not necessary, then the solver will find that there is no + -- solution before starting to solve for 'v', and the new final conflict set + -- will be very likely to not contain 'v'. If 'v' is necessary, the solver + -- will most likely need to try solving for 'v' before finding that there is + -- no solution, and the new final conflict set will still contain 'v'. + -- However, this method isn't perfect, because it is possible for the solver + -- to add new unnecessary variables to the conflict set on any run. This + -- function prevents the conflict set from growing by checking that the new + -- conflict set is a subset of the old one and falling back to using the old + -- conflict set when that check fails. + tryToRemoveOneVar :: Var QPN + -> ConflictSet + -> ConflictMap + -> RetryLog String SolverFailure a + tryToRemoveOneVar v smallestKnownCS smallestKnownCM + -- Check whether v is still present, because it may have already been + -- removed in a previous solver rerun. + | not (v `CS.member` smallestKnownCS) = + fromProgress $ Fail $ ExhaustiveSearch smallestKnownCS smallestKnownCM + | otherwise = + continueWith ("Trying to remove variable " ++ varStr ++ " from the " + ++ "conflict set.") $ + retry (runSolver sc') $ \case + err@(ExhaustiveSearch cs' _) + | CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS -> + let msg = if not $ CS.member v cs' + then "Successfully removed " ++ varStr ++ " from " + ++ "the conflict set." + else "Failed to remove " ++ varStr ++ " from the " + ++ "conflict set." + in -- Use the new conflict set, even if v wasn't removed, + -- because other variables may have been removed. + failWith (msg ++ " Continuing with " ++ showCS cs' ++ ".") err + | otherwise -> + failWith ("Failed to find a smaller conflict set. The new " + ++ "conflict set is not a subset of the previous " + ++ "conflict set: " ++ showCS cs') $ + ExhaustiveSearch smallestKnownCS smallestKnownCM + BackjumpLimitReached -> + failWith ("Reached backjump limit while minimizing conflict set.") + BackjumpLimitReached + where + varStr = "\"" ++ showVar v ++ "\"" + showCS cs' = "{" ++ showConflictSet cs' ++ "}" + + sc' = sc { goalOrder = Just goalOrder' } + + goalOrder' = + preferGoalsFromConflictSet (v `CS.delete` smallestKnownCS) + <> preferGoal v + <> fromMaybe mempty (goalOrder sc) + + -- Like 'retry', except that it only applies the input function when the + -- backjump limit has not been reached. + retryNoSolution :: RetryLog step SolverFailure done + -> (ConflictSet -> ConflictMap -> RetryLog step SolverFailure done) + -> RetryLog step SolverFailure done + retryNoSolution lg f = retry lg $ \case + ExhaustiveSearch cs' cm' -> f cs' cm' + BackjumpLimitReached -> fromProgress (Fail BackjumpLimitReached) + -- | Goal ordering that chooses goals contained in the conflict set before -- other goals. preferGoalsFromConflictSet :: ConflictSet -> Variable QPN -> Variable QPN -> Ordering -preferGoalsFromConflictSet cs = - comparing $ \v -> not $ CS.member (toVar v) cs - where - toVar :: Variable QPN -> Var QPN - toVar (PackageVar qpn) = P qpn - toVar (FlagVar qpn fn) = F (FN qpn fn) - toVar (StanzaVar qpn sn) = S (SN qpn sn) +preferGoalsFromConflictSet cs = comparing $ \v -> not $ CS.member (toVar v) cs + +-- | Goal ordering that chooses the given goal first. +preferGoal :: Var QPN -> Variable QPN -> Variable QPN -> Ordering +preferGoal preferred = comparing $ \v -> toVar v /= preferred + +toVar :: Variable QPN -> Var QPN +toVar (PackageVar qpn) = P qpn +toVar (FlagVar qpn fn) = F (FN qpn fn) +toVar (StanzaVar qpn sn) = S (SN qpn sn) + +finalErrorMsg :: SolverConfig -> SolverFailure -> String +finalErrorMsg sc failure = + case failure of + ExhaustiveSearch cs cm -> + "After searching the rest of the dependency tree exhaustively, " + ++ "these were the goals I've had most trouble fulfilling: " + ++ showCS cm cs + ++ flagSuggestion + where + showCS = if solverVerbosity sc > normal + then CS.showCSWithFrequency + else CS.showCSSortedByFrequency + flagSuggestion = + -- Don't suggest --minimize-conflict-set if the conflict set is + -- already small, because it is unlikely to be reduced further. + if CS.size cs > 3 && not (asBool (minimizeConflictSet sc)) + then "\nTry running with --minimize-conflict-set to improve the " + ++ "error message." + else "" + BackjumpLimitReached -> + "Backjump limit reached (" ++ currlimit (maxBackjumps sc) ++ + "change with --max-backjumps or try to run with --reorder-goals).\n" + where currlimit (Just n) = "currently " ++ show n ++ ", " + currlimit Nothing = "" diff --git a/Distribution/Solver/Modular/Builder.hs b/Distribution/Solver/Modular/Builder.hs --- a/Distribution/Solver/Modular/Builder.hs +++ b/Distribution/Solver/Modular/Builder.hs @@ -24,6 +24,7 @@ import Data.Set as S import Prelude hiding (sequence, mapM) +import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Index @@ -143,13 +144,8 @@ -- For a package, we look up the instances available in the global info, -- and then handle each instance in turn. addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) = - -- If the package does not exist in the index, we construct an emty PChoiceF node for it - -- After all, we have no choices here. Alternatively, we could immediately construct - -- a Fail node here, but that would complicate the construction of conflict sets. - -- We will probably want to give this case special treatment when generating error - -- messages though. case M.lookup pn idx of - Nothing -> PChoiceF qpn rdm gr (W.fromList []) + Nothing -> FailF (varToConflictSet (P qpn) `CS.union` goalReasonToCS gr) UnknownPackage Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) -> ([], POption i Nothing, bs { next = Instance qpn info })) (M.toList pis))) diff --git a/Distribution/Solver/Modular/ConflictSet.hs b/Distribution/Solver/Modular/ConflictSet.hs --- a/Distribution/Solver/Modular/ConflictSet.hs +++ b/Distribution/Solver/Modular/ConflictSet.hs @@ -18,12 +18,15 @@ , showCSSortedByFrequency , showCSWithFrequency -- Set-like operations + , toSet , toList , union , unions , insert + , delete , empty , singleton + , size , member , filter , fromList @@ -98,6 +101,9 @@ Set-like operations -------------------------------------------------------------------------------} +toSet :: ConflictSet -> Set (Var QPN) +toSet = conflictSetToSet + toList :: ConflictSet -> [Var QPN] toList = S.toList . conflictSetToSet @@ -137,6 +143,11 @@ #endif } +delete :: Var QPN -> ConflictSet -> ConflictSet +delete var cs = CS { + conflictSetToSet = S.delete var (conflictSetToSet cs) + } + empty :: #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => @@ -160,6 +171,9 @@ , conflictSetOrigin = Node ?loc [] #endif } + +size :: ConflictSet -> Int +size = S.size . conflictSetToSet member :: Var QPN -> ConflictSet -> Bool member var = S.member var . conflictSetToSet diff --git a/Distribution/Solver/Modular/Dependency.hs b/Distribution/Solver/Modular/Dependency.hs --- a/Distribution/Solver/Modular/Dependency.hs +++ b/Distribution/Solver/Modular/Dependency.hs @@ -52,6 +52,7 @@ import Distribution.Solver.Types.ComponentDeps (Component(..)) import Distribution.Solver.Types.PackagePath +import Distribution.Types.PkgconfigVersionRange import Distribution.Types.UnqualComponentName {------------------------------------------------------------------------------- @@ -117,7 +118,7 @@ data Dep qpn = Dep (PkgComponent qpn) CI -- ^ dependency on a package component | Ext Extension -- ^ dependency on a language extension | Lang Language -- ^ dependency on a language version - | Pkg PkgconfigName VR -- ^ dependency on a pkg-config package + | Pkg PkgconfigName PkgconfigVersionRange -- ^ dependency on a pkg-config package deriving Functor -- | An exposed component within a package. This type is used to represent diff --git a/Distribution/Solver/Modular/Explore.hs b/Distribution/Solver/Modular/Explore.hs --- a/Distribution/Solver/Modular/Explore.hs +++ b/Distribution/Solver/Modular/Explore.hs @@ -1,9 +1,7 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Solver.Modular.Explore - ( backjump - , backjumpAndExplore - ) where +module Distribution.Solver.Modular.Explore (backjumpAndExplore) where import qualified Distribution.Solver.Types.Progress as P @@ -54,40 +52,51 @@ combine :: forall a . (ExploreState -> ConflictSetLog a) -> (ConflictSet -> ExploreState -> ConflictSetLog a) -> ConflictSet -> ExploreState -> ConflictSetLog a - combine x f csAcc es = retry (x es) next + combine x f csAcc es = retryNoSolution (x es) next where - next :: IntermediateFailure -> ConflictSetLog a - next BackjumpLimit = fromProgress (P.Fail BackjumpLimit) - next (NoSolution !cs es') - | enableBj && not (var `CS.member` cs) = skipLoggingBackjump cs es' - | otherwise = f (csAcc `CS.union` cs) es' + next :: ConflictSet -> ExploreState -> ConflictSetLog a + next !cs es' = if enableBj && not (var `CS.member` cs) + then skipLoggingBackjump cs es' + else f (csAcc `CS.union` cs) es' -- This function represents the option to not choose a value for this goal. avoidGoal :: ConflictSet -> ExploreState -> ConflictSetLog a avoidGoal cs !es = - logBackjump (cs `CS.union` lastCS) $ + logBackjump mbj (cs `CS.union` lastCS) $ -- Use 'lastCS' below instead of 'cs' since we do not want to -- double-count the additionally accumulated conflicts. es { esConflictMap = updateCM lastCS (esConflictMap es) } - logBackjump :: ConflictSet -> ExploreState -> ConflictSetLog a - logBackjump cs es = - failWith (Failure cs Backjump) $ - if reachedBjLimit (esBackjumps es) - then BackjumpLimit - else NoSolution cs es { esBackjumps = esBackjumps es + 1 } - where - reachedBjLimit = case mbj of - Nothing -> const False - Just limit -> (== limit) - -- The solver does not count or log backjumps at levels where the conflict -- set does not contain the current variable. Otherwise, there would be many -- consecutive log messages about backjumping with the same conflict set. skipLoggingBackjump :: ConflictSet -> ExploreState -> ConflictSetLog a skipLoggingBackjump cs es = fromProgress $ P.Fail (NoSolution cs es) +-- | Creates a failing ConflictSetLog representing a backjump. It inserts a +-- "backjumping" message, checks whether the backjump limit has been reached, +-- and increments the backjump count. +logBackjump :: Maybe Int -> ConflictSet -> ExploreState -> ConflictSetLog a +logBackjump mbj cs es = + failWith (Failure cs Backjump) $ + if reachedBjLimit (esBackjumps es) + then BackjumpLimit + else NoSolution cs es { esBackjumps = esBackjumps es + 1 } + where + reachedBjLimit = case mbj of + Nothing -> const False + Just limit -> (== limit) + +-- | Like 'retry', except that it only applies the input function when the +-- backjump limit has not been reached. +retryNoSolution :: ConflictSetLog a + -> (ConflictSet -> ExploreState -> ConflictSetLog a) + -> ConflictSetLog a +retryNoSolution lg f = retry lg $ \case + BackjumpLimit -> fromProgress (P.Fail BackjumpLimit) + NoSolution cs es -> f cs es + -- | The state that is read and written while exploring the search tree. data ExploreState = ES { esConflictMap :: !ConflictMap @@ -138,14 +147,15 @@ exploreLog :: Maybe Int -> EnableBackjumping -> CountConflicts -> Tree Assignment QGoalReason -> ConflictSetLog (Assignment, RevDepMap) -exploreLog mbj enableBj (CountConflicts countConflicts) t = cata go t initES +exploreLog mbj enableBj (CountConflicts countConflicts) t = para go t initES where getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a) getBestGoal' | countConflicts = \ ts cm -> getBestGoal cm ts | otherwise = \ ts _ -> getFirstGoal ts - go :: TreeF Assignment QGoalReason (ExploreState -> ConflictSetLog (Assignment, RevDepMap)) + go :: TreeF Assignment QGoalReason + (ExploreState -> ConflictSetLog (Assignment, RevDepMap), Tree Assignment QGoalReason) -> (ExploreState -> ConflictSetLog (Assignment, RevDepMap)) go (FailF c fr) = \ !es -> let es' = es { esConflictMap = updateCM c (esConflictMap es) } @@ -155,20 +165,29 @@ backjump mbj enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, W.mapWithKey -- when descending ... (\ k r es -> tryWith (TryP qpn k) (r es)) - ts + (fmap fst ts) go (FChoiceF qfn _ gr _ _ _ ts) = backjump mbj enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, W.mapWithKey -- when descending ... (\ k r es -> tryWith (TryF qfn k) (r es)) - ts + (fmap fst ts) go (SChoiceF qsn _ gr _ ts) = backjump mbj enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, W.mapWithKey -- when descending ... (\ k r es -> tryWith (TryS qsn k) (r es)) - ts + (fmap fst ts) go (GoalChoiceF _ ts) = \ es -> - let (k, v) = getBestGoal' ts (esConflictMap es) - in continueWith (Next k) (v es) + let (k, (v, tree)) = getBestGoal' ts (esConflictMap es) + in continueWith (Next k) $ + -- Goal choice nodes are normally not counted as backjumps, since the + -- solver always explores exactly one choice, which means that the + -- backjump from the goal choice would be redundant with the backjump + -- from the PChoice, FChoice, or SChoice below. The one case where the + -- backjump is not redundant is when the chosen goal is a failure node, + -- so we log a backjump in that case. + case tree of + Fail _ _ -> retryNoSolution (v es) $ logBackjump mbj + _ -> v es initES = ES { esConflictMap = M.empty diff --git a/Distribution/Solver/Modular/IndexConversion.hs b/Distribution/Solver/Modular/IndexConversion.hs --- a/Distribution/Solver/Modular/IndexConversion.hs +++ b/Distribution/Solver/Modular/IndexConversion.hs @@ -86,7 +86,7 @@ convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi) where MungedPackageId mpn ver = mungedId ipi -- HACK. See Note [Index conversion with internal libraries] - pn = mkPackageName (unMungedPackageName mpn) + pn = encodeCompatPackageName mpn -- | Convert a single installed package into the solver-specific format. convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) @@ -100,7 +100,7 @@ (pn, i) = convId ipi -- 'sourceLibName' is unreliable, but for now we only really use this for -- primary libs anyways - comp = componentNameToComponent $ libraryComponentName $ sourceLibName ipi + comp = componentNameToComponent $ CLibName $ sourceLibName ipi -- TODO: Installed packages should also store their encapsulations! -- Note [Index conversion with internal libraries] @@ -335,7 +335,7 @@ -- | Convenience function to delete a 'Dependency' if it's -- for a 'PN' that isn't actually real. filterIPNs :: IPNs -> Dependency -> Maybe Dependency -filterIPNs ipns d@(Dependency pn _) +filterIPNs ipns d@(Dependency pn _ _) | S.notMember pn ipns = Just d | otherwise = Nothing @@ -562,7 +562,7 @@ -- | Convert a Cabal dependency on a library to a solver-specific dependency. convLibDep :: DependencyReason PN -> Dependency -> LDep PN -convLibDep dr (Dependency pn vr) = LDep dr $ Dep (PkgComponent pn ExposedLib) (Constrained vr) +convLibDep dr (Dependency pn vr _) = LDep dr $ Dep (PkgComponent pn ExposedLib) (Constrained vr) -- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency. convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN diff --git a/Distribution/Solver/Modular/Log.hs b/Distribution/Solver/Modular/Log.hs --- a/Distribution/Solver/Modular/Log.hs +++ b/Distribution/Solver/Modular/Log.hs @@ -1,5 +1,5 @@ module Distribution.Solver.Modular.Log - ( logToProgress + ( displayLogMessages , SolverFailure(..) ) where @@ -10,47 +10,22 @@ import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Message -import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.RetryLog -import Distribution.Verbosity -- | Information about a dependency solver failure. data SolverFailure = ExhaustiveSearch ConflictSet ConflictMap | BackjumpLimitReached --- | Postprocesses a log file. When the dependency solver fails to find a --- solution, the log ends with a SolverFailure and a message describing the --- failure. This function discards all log messages and avoids calling --- 'showMessages' if the log isn't needed (specified by 'keepLog'), for --- efficiency. -logToProgress :: Bool - -> Verbosity - -> Maybe Int - -> RetryLog Message SolverFailure a - -> Progress String (SolverFailure, String) a -logToProgress keepLog verbosity mbj lg = +-- | Postprocesses a log file. This function discards all log messages and +-- avoids calling 'showMessages' if the log isn't needed (specified by +-- 'keepLog'), for efficiency. +displayLogMessages :: Bool + -> RetryLog Message SolverFailure a + -> RetryLog String SolverFailure a +displayLogMessages keepLog lg = fromProgress $ if keepLog then showMessages progress else foldProgress (const id) Fail Done progress where - progress = - -- Convert the RetryLog to a Progress (with toProgress) as late as - -- possible, to take advantage of efficient updates at failures. - toProgress $ - mapFailure (\failure -> (failure, finalErrorMsg failure)) lg - - finalErrorMsg :: SolverFailure -> String - finalErrorMsg (ExhaustiveSearch cs cm) = - "After searching the rest of the dependency tree exhaustively, " - ++ "these were the goals I've had most trouble fulfilling: " - ++ showCS cm cs - where - showCS = if verbosity > normal - then CS.showCSWithFrequency - else CS.showCSSortedByFrequency - finalErrorMsg BackjumpLimitReached = - "Backjump limit reached (" ++ currlimit mbj ++ - "change with --max-backjumps or try to run with --reorder-goals).\n" - where currlimit (Just n) = "currently " ++ show n ++ ", " - currlimit Nothing = "" + progress = toProgress lg diff --git a/Distribution/Solver/Modular/Message.hs b/Distribution/Solver/Modular/Message.hs --- a/Distribution/Solver/Modular/Message.hs +++ b/Distribution/Solver/Modular/Message.hs @@ -8,7 +8,7 @@ import qualified Data.List as L import Prelude hiding (pi) -import Distribution.Text -- from Cabal +import Distribution.Pretty (prettyShow) -- from Cabal import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag @@ -53,10 +53,8 @@ (atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms) go !l (Step (Next (Goal (P _ ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) = (atLevel l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms) - go !l (Step (Next (Goal (P qpn) gr)) ms@(Step (Failure _c Backjump) _)) = + go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) = (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms - go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) = - (atLevel l $ showPackageGoal qpn gr) $ (atLevel l $ showFailure c fr) (go l ms) -- standard display go !l (Step Enter ms) = go (l+1) ms go !l (Step Leave ms) = go (l-1) ms @@ -104,9 +102,9 @@ showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")" showFR :: ConflictSet -> FailReason -> String -showFR _ (UnsupportedExtension ext) = " (conflict: requires " ++ display ext ++ ")" -showFR _ (UnsupportedLanguage lang) = " (conflict: requires " ++ display lang ++ ")" -showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ display pn ++ display vr ++ ", not found in the pkg-config database)" +showFR _ (UnsupportedExtension ext) = " (conflict: requires " ++ prettyShow ext ++ ")" +showFR _ (UnsupportedLanguage lang) = " (conflict: requires " ++ prettyShow lang ++ ")" +showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ ", not found in the pkg-config database)" showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")" showFR _ (ConflictingConstraints d1 d2) = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")" showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")" @@ -115,9 +113,11 @@ showFR _ (PackageRequiresUnbuildableComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is not buildable in the current environment)" showFR _ CannotInstall = " (only already installed instances can be used)" showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" +showFR _ NotExplicit = " (not a user-provided goal nor mentioned as a constraint, but reject-unconstrained-dependencies was set)" showFR _ Shadowed = " (shadowed by another installed package with same version)" showFR _ Broken = " (package is broken)" -showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ display vr ++ ")" +showFR _ UnknownPackage = " (unknown package)" +showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")" showFR _ (GlobalConstraintInstalled src) = " (" ++ constraintSource src ++ " requires installed instance)" showFR _ (GlobalConstraintSource src) = " (" ++ constraintSource src ++ " requires source instance)" showFR _ (GlobalConstraintFlag src) = " (" ++ constraintSource src ++ " requires opposite flag selection)" @@ -126,7 +126,7 @@ showFR _ MultipleInstances = " (multiple instances)" showFR c (DependenciesNotLinked msg) = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")" showFR c CyclicDependencies = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")" -showFR _ (UnsupportedSpecVer ver) = " (unsupported spec-version " ++ display ver ++ ")" +showFR _ (UnsupportedSpecVer ver) = " (unsupported spec-version " ++ prettyShow ver ++ ")" -- The following are internal failures. They should not occur. In the -- interest of not crashing unnecessarily, we still just print an error -- message though. diff --git a/Distribution/Solver/Modular/Package.hs b/Distribution/Solver/Modular/Package.hs --- a/Distribution/Solver/Modular/Package.hs +++ b/Distribution/Solver/Modular/Package.hs @@ -21,7 +21,7 @@ import Data.List as L import Distribution.Package -- from Cabal -import Distribution.Text (display) +import Distribution.Deprecated.Text (display) import Distribution.Solver.Modular.Version import Distribution.Solver.Types.PackagePath diff --git a/Distribution/Solver/Modular/Preference.hs b/Distribution/Solver/Modular/Preference.hs --- a/Distribution/Solver/Modular/Preference.hs +++ b/Distribution/Solver/Modular/Preference.hs @@ -13,6 +13,7 @@ , preferPackagePreferences , preferReallyEasyGoalChoices , requireInstalled + , onlyConstrained , sortGoals , pruneAfterFirstSuccess ) where @@ -336,6 +337,15 @@ notReinstall _ _ x = x go x = x + +-- | Require all packages to be mentioned in a constraint or as a goal. +onlyConstrained :: (PN -> Bool) -> Tree d QGoalReason -> Tree d QGoalReason +onlyConstrained p = trav go + where + go (PChoiceF v@(Q _ pn) _ gr _) | not (p pn) + = FailF (varToConflictSet (P v) `CS.union` goalReasonToCS gr) NotExplicit + go x + = x -- | Sort all goals using the provided function. sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree d c -> Tree d c diff --git a/Distribution/Solver/Modular/Solver.hs b/Distribution/Solver/Modular/Solver.hs --- a/Distribution/Solver/Modular/Solver.hs +++ b/Distribution/Solver/Modular/Solver.hs @@ -45,7 +45,7 @@ #ifdef DEBUG_TRACETREE import qualified Distribution.Solver.Modular.ConflictSet as CS import qualified Distribution.Solver.Modular.WeightedPSQ as W -import qualified Distribution.Text as T +import qualified Distribution.Deprecated.Text as T import Debug.Trace.Tree (gtraceJson) import Debug.Trace.Tree.Simple @@ -57,11 +57,13 @@ data SolverConfig = SolverConfig { reorderGoals :: ReorderGoals, countConflicts :: CountConflicts, + minimizeConflictSet :: MinimizeConflictSet, independentGoals :: IndependentGoals, avoidReinstalls :: AvoidReinstalls, shadowPkgs :: ShadowPkgs, strongFlags :: StrongFlags, allowBootLibInstalls :: AllowBootLibInstalls, + onlyConstrained :: OnlyConstrained, maxBackjumps :: Maybe Int, enableBackjumping :: EnableBackjumping, solveExecutables :: SolveExecutables, @@ -129,9 +131,19 @@ prunePhase = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) . (if asBool (allowBootLibInstalls sc) then id - else P.requireInstalled (`elem` nonInstallable)) + else P.requireInstalled (`elem` nonInstallable)) . + (case onlyConstrained sc of + OnlyConstrainedAll -> + P.onlyConstrained pkgIsExplicit + OnlyConstrainedNone -> + id) buildPhase = traceTree "build.json" id $ buildTree idx (independentGoals sc) (S.toList userGoals) + + allExplicit = M.keysSet userConstraints `S.union` userGoals + + pkgIsExplicit :: PN -> Bool + pkgIsExplicit pn = S.member pn allExplicit -- packages that can never be installed or upgraded -- If you change this enumeration, make sure to update the list in diff --git a/Distribution/Solver/Modular/Tree.hs b/Distribution/Solver/Modular/Tree.hs --- a/Distribution/Solver/Modular/Tree.hs +++ b/Distribution/Solver/Modular/Tree.hs @@ -31,6 +31,7 @@ import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.Flag import Distribution.Solver.Types.PackagePath +import Distribution.Types.PkgconfigVersionRange import Language.Haskell.Extension (Extension, Language) type Weight = Double @@ -97,7 +98,7 @@ data FailReason = UnsupportedExtension Extension | UnsupportedLanguage Language - | MissingPkgconfigPackage PkgconfigName VR + | MissingPkgconfigPackage PkgconfigName PkgconfigVersionRange | NewPackageDoesNotMatchExistingConstraint ConflictingDep | ConflictingConstraints ConflictingDep ConflictingDep | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN) @@ -106,8 +107,10 @@ | PackageRequiresUnbuildableComponent QPN ExposedComponent | CannotInstall | CannotReinstall + | NotExplicit | Shadowed | Broken + | UnknownPackage | GlobalConstraintVersion VR ConstraintSource | GlobalConstraintInstalled ConstraintSource | GlobalConstraintSource ConstraintSource diff --git a/Distribution/Solver/Modular/Validate.hs b/Distribution/Solver/Modular/Validate.hs --- a/Distribution/Solver/Modular/Validate.hs +++ b/Distribution/Solver/Modular/Validate.hs @@ -37,6 +37,7 @@ import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) +import Distribution.Types.PkgconfigVersionRange #ifdef DEBUG_CONFLICT_SETS import GHC.Stack (CallStack) @@ -96,7 +97,7 @@ data ValidateState = VS { supportedExt :: Extension -> Bool, supportedLang :: Language -> Bool, - presentPkgs :: PkgconfigName -> VR -> Bool, + presentPkgs :: PkgconfigName -> PkgconfigVersionRange -> Bool, index :: Index, -- Saved, scoped, dependencies. Every time 'validate' makes a package choice, @@ -382,7 +383,7 @@ -- or the successfully extended assignment. extend :: (Extension -> Bool) -- ^ is a given extension supported -> (Language -> Bool) -- ^ is a given language supported - -> (PkgconfigName -> VR -> Bool) -- ^ is a given pkg-config requirement satisfiable + -> (PkgconfigName -> PkgconfigVersionRange -> Bool) -- ^ is a given pkg-config requirement satisfiable -> [LDep QPN] -> PPreAssignment -> Either Conflict PPreAssignment diff --git a/Distribution/Solver/Modular/Version.hs b/Distribution/Solver/Modular/Version.hs --- a/Distribution/Solver/Modular/Version.hs +++ b/Distribution/Solver/Modular/Version.hs @@ -12,7 +12,7 @@ ) where import qualified Distribution.Version as CV -- from Cabal -import Distribution.Text -- from Cabal +import Distribution.Deprecated.Text -- from Cabal -- | Preliminary type for versions. type Ver = CV.Version diff --git a/Distribution/Solver/Types/ComponentDeps.hs b/Distribution/Solver/Types/ComponentDeps.hs --- a/Distribution/Solver/Types/ComponentDeps.hs +++ b/Distribution/Solver/Types/ComponentDeps.hs @@ -44,6 +44,7 @@ import Data.Foldable (fold) import qualified Distribution.Types.ComponentName as CN +import qualified Distribution.Types.LibraryName as LN {------------------------------------------------------------------------------- Types @@ -90,12 +91,12 @@ instance Binary a => Binary (ComponentDeps a) componentNameToComponent :: CN.ComponentName -> Component -componentNameToComponent (CN.CLibName) = ComponentLib -componentNameToComponent (CN.CSubLibName s) = ComponentSubLib s -componentNameToComponent (CN.CFLibName s) = ComponentFLib s -componentNameToComponent (CN.CExeName s) = ComponentExe s -componentNameToComponent (CN.CTestName s) = ComponentTest s -componentNameToComponent (CN.CBenchName s) = ComponentBench s +componentNameToComponent (CN.CLibName LN.LMainLibName) = ComponentLib +componentNameToComponent (CN.CLibName (LN.LSubLibName s)) = ComponentSubLib s +componentNameToComponent (CN.CFLibName s) = ComponentFLib s +componentNameToComponent (CN.CExeName s) = ComponentExe s +componentNameToComponent (CN.CTestName s) = ComponentTest s +componentNameToComponent (CN.CBenchName s) = ComponentBench s {------------------------------------------------------------------------------- Construction @@ -118,9 +119,9 @@ -- | Zip two 'ComponentDeps' together by 'Component', using 'mempty' -- as the neutral element when a 'Component' is present only in one. -zip :: (Monoid a, Monoid b) => ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b) -{- TODO/FIXME: Once we can expect containers>=0.5, switch to the more efficient version below: - +zip + :: (Monoid a, Monoid b) + => ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b) zip (ComponentDeps d1) (ComponentDeps d2) = ComponentDeps $ Map.mergeWithKey @@ -128,15 +129,6 @@ (fmap (\a -> (a, mempty))) (fmap (\b -> (mempty, b))) d1 d2 - --} -zip (ComponentDeps d1) (ComponentDeps d2) = - ComponentDeps $ - Map.unionWith - mappend - (Map.map (\a -> (a, mempty)) d1) - (Map.map (\b -> (mempty, b)) d2) - -- | Keep only selected components (and their associated deps info). filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a diff --git a/Distribution/Solver/Types/InstSolverPackage.hs b/Distribution/Solver/Types/InstSolverPackage.hs --- a/Distribution/Solver/Types/InstSolverPackage.hs +++ b/Distribution/Solver/Types/InstSolverPackage.hs @@ -9,7 +9,6 @@ import Distribution.Solver.Types.SolverId import Distribution.Types.MungedPackageId import Distribution.Types.PackageId -import Distribution.Types.PackageName import Distribution.Types.MungedPackageName import Distribution.InstalledPackageInfo (InstalledPackageInfo) import GHC.Generics (Generic) @@ -29,7 +28,7 @@ packageId i = -- HACK! See Note [Index conversion with internal libraries] let MungedPackageId mpn v = mungedId i - in PackageIdentifier (mkPackageName (unMungedPackageName mpn)) v + in PackageIdentifier (encodeCompatPackageName mpn) v instance HasMungedPackageId InstSolverPackage where mungedId = mungedId . instSolverPkgIPI diff --git a/Distribution/Solver/Types/PackageConstraint.hs b/Distribution/Solver/Types/PackageConstraint.hs --- a/Distribution/Solver/Types/PackageConstraint.hs +++ b/Distribution/Solver/Types/PackageConstraint.hs @@ -22,16 +22,18 @@ import Distribution.Package (PackageName) import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) import Distribution.Types.Dependency (Dependency(..)) +import Distribution.Types.LibraryName (LibraryName(..)) import Distribution.Version (VersionRange, simplifyVersionRange) import Distribution.Solver.Compat.Prelude ((<<>>)) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath -import Distribution.Text (disp, flatStyle) +import Distribution.Deprecated.Text (disp, flatStyle) import GHC.Generics (Generic) import Text.PrettyPrint ((<+>)) import qualified Text.PrettyPrint as Disp +import qualified Data.Set as Set -- | Determines to what packages and in what contexts a @@ -142,7 +144,7 @@ packageConstraintToDependency (PackageConstraint scope prop) = toDep prop where toDep (PackagePropertyVersion vr) = - Just $ Dependency (scopeToPackageName scope) vr + Just $ Dependency (scopeToPackageName scope) vr (Set.singleton LMainLibName) toDep (PackagePropertyInstalled) = Nothing toDep (PackagePropertySource) = Nothing toDep (PackagePropertyFlags _) = Nothing diff --git a/Distribution/Solver/Types/PackageIndex.hs b/Distribution/Solver/Types/PackageIndex.hs --- a/Distribution/Solver/Types/PackageIndex.hs +++ b/Distribution/Solver/Types/PackageIndex.hs @@ -55,12 +55,12 @@ import Distribution.Package ( PackageName, unPackageName, PackageIdentifier(..) , Package(..), packageName, packageVersion ) -import Distribution.Types.Dependency import Distribution.Version - ( withinRange ) + ( VersionRange, withinRange ) import Distribution.Simple.Utils ( lowercase, comparing ) +import qualified Prelude (foldr1) -- | The collection of information about packages from one or more 'PackageDB's. -- @@ -86,7 +86,7 @@ mappend = (<>) --save one mappend with empty in the common case: mconcat [] = mempty - mconcat xs = foldr1 mappend xs + mconcat xs = Prelude.foldr1 mappend xs instance Binary pkg => Binary (PackageIndex pkg) @@ -210,10 +210,10 @@ delete name (\pkg -> packageName pkg == name) -- | Removes all packages satisfying this dependency from the index. --- -deleteDependency :: Package pkg => Dependency -> PackageIndex pkg +deleteDependency :: Package pkg + => PackageName -> VersionRange -> PackageIndex pkg -> PackageIndex pkg -deleteDependency (Dependency name verstionRange) = +deleteDependency name verstionRange = delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) -- @@ -269,8 +269,11 @@ -- We get back any number of versions of the specified package name, all -- satisfying the version range constraint. -- -lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg] -lookupDependency index (Dependency name versionRange) = +lookupDependency :: Package pkg + => PackageIndex pkg + -> PackageName -> VersionRange + -> [pkg] +lookupDependency index name versionRange = [ pkg | pkg <- lookup index name , packageName pkg == name , packageVersion pkg `withinRange` versionRange ] diff --git a/Distribution/Solver/Types/PackagePath.hs b/Distribution/Solver/Types/PackagePath.hs --- a/Distribution/Solver/Types/PackagePath.hs +++ b/Distribution/Solver/Types/PackagePath.hs @@ -10,7 +10,7 @@ ) where import Distribution.Package -import Distribution.Text +import Distribution.Deprecated.Text import qualified Text.PrettyPrint as Disp import Distribution.Solver.Compat.Prelude ((<<>>)) diff --git a/Distribution/Solver/Types/PkgConfigDb.hs b/Distribution/Solver/Types/PkgConfigDb.hs --- a/Distribution/Solver/Types/PkgConfigDb.hs +++ b/Distribution/Solver/Types/PkgConfigDb.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Solver.Types.PkgConfigDb @@ -20,33 +20,27 @@ , getPkgConfigDbDirs ) where -import Prelude () import Distribution.Solver.Compat.Prelude - -import Control.Exception (IOException, handle) -import qualified Data.Map as M -import Data.Version (parseVersion) -import Text.ParserCombinators.ReadP (readP_to_S) -import System.FilePath (splitSearchPath) +import Prelude () -import Distribution.Package - ( PkgconfigName, mkPkgconfigName ) -import Distribution.Verbosity - ( Verbosity ) -import Distribution.Version - ( Version, mkVersion', VersionRange, withinRange ) +import Control.Exception (IOException, handle) +import qualified Data.Map as M +import System.FilePath (splitSearchPath) -import Distribution.Compat.Environment - ( lookupEnv ) +import Distribution.Compat.Environment (lookupEnv) +import Distribution.Package (PkgconfigName, mkPkgconfigName) +import Distribution.Parsec import Distribution.Simple.Program - ( ProgramDb, pkgConfigProgram, getProgramOutput, requireProgram ) -import Distribution.Simple.Utils - ( info ) + (ProgramDb, getProgramOutput, pkgConfigProgram, requireProgram) +import Distribution.Simple.Utils (info) +import Distribution.Types.PkgconfigVersion +import Distribution.Types.PkgconfigVersionRange +import Distribution.Verbosity (Verbosity) -- | The list of packages installed in the system visible to -- @pkg-config@. This is an opaque datatype, to be constructed with -- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`. -data PkgConfigDb = PkgConfigDb (M.Map PkgconfigName (Maybe Version)) +data PkgConfigDb = PkgConfigDb (M.Map PkgconfigName (Maybe PkgconfigVersion)) -- ^ If an entry is `Nothing`, this means that the -- package seems to be present, but we don't know the -- exact version (because parsing of the version @@ -84,22 +78,17 @@ pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs where - convert :: (String, String) -> (PkgconfigName, Maybe Version) - convert (n,vs) = (mkPkgconfigName n, - case (reverse . readP_to_S parseVersion) vs of - (v, "") : _ -> Just (mkVersion' v) - _ -> Nothing -- Version not (fully) - -- understood. - ) + convert :: (String, String) -> (PkgconfigName, Maybe PkgconfigVersion) + convert (n,vs) = (mkPkgconfigName n, simpleParsec vs) -- | Check whether a given package range is satisfiable in the given -- @pkg-config@ database. -pkgConfigPkgIsPresent :: PkgConfigDb -> PkgconfigName -> VersionRange -> Bool +pkgConfigPkgIsPresent :: PkgConfigDb -> PkgconfigName -> PkgconfigVersionRange -> Bool pkgConfigPkgIsPresent (PkgConfigDb db) pn vr = case M.lookup pn db of Nothing -> False -- Package not present in the DB. Just Nothing -> True -- Package present, but version unknown. - Just (Just v) -> withinRange v vr + Just (Just v) -> withinPkgconfigVersionRange v vr -- If we could not read the pkg-config database successfully we allow -- the check to succeed. The plan found by the solver may fail to be -- executed later on, but we have no grounds for rejecting the plan at @@ -111,7 +100,7 @@ -- @Nothing@ indicates the package is not in the database, while -- @Just Nothing@ indicates that the package is in the database, -- but its version is not known. -pkgConfigDbPkgVersion :: PkgConfigDb -> PkgconfigName -> Maybe (Maybe Version) +pkgConfigDbPkgVersion :: PkgConfigDb -> PkgconfigName -> Maybe (Maybe PkgconfigVersion) pkgConfigDbPkgVersion (PkgConfigDb db) pn = M.lookup pn db -- NB: Since the solver allows solving to succeed if there is -- NoPkgConfigDb, we should report that we *guess* that there diff --git a/Distribution/Solver/Types/Settings.hs b/Distribution/Solver/Types/Settings.hs --- a/Distribution/Solver/Types/Settings.hs +++ b/Distribution/Solver/Types/Settings.hs @@ -3,10 +3,12 @@ module Distribution.Solver.Types.Settings ( ReorderGoals(..) , IndependentGoals(..) + , MinimizeConflictSet(..) , AvoidReinstalls(..) , ShadowPkgs(..) , StrongFlags(..) , AllowBootLibInstalls(..) + , OnlyConstrained(..) , EnableBackjumping(..) , CountConflicts(..) , SolveExecutables(..) @@ -14,14 +16,22 @@ import Distribution.Simple.Setup ( BooleanFlag(..) ) import Distribution.Compat.Binary (Binary(..)) +import Distribution.Pretty ( Pretty(pretty) ) +import Distribution.Deprecated.Text ( Text(parse) ) import GHC.Generics (Generic) +import qualified Distribution.Deprecated.ReadP as Parse +import qualified Text.PrettyPrint as PP + newtype ReorderGoals = ReorderGoals Bool deriving (BooleanFlag, Eq, Generic, Show) newtype CountConflicts = CountConflicts Bool deriving (BooleanFlag, Eq, Generic, Show) +newtype MinimizeConflictSet = MinimizeConflictSet Bool + deriving (BooleanFlag, Eq, Generic, Show) + newtype IndependentGoals = IndependentGoals Bool deriving (BooleanFlag, Eq, Generic, Show) @@ -37,6 +47,13 @@ newtype AllowBootLibInstalls = AllowBootLibInstalls Bool deriving (BooleanFlag, Eq, Generic, Show) +-- | Should we consider all packages we know about, or only those that +-- have constraints explicitly placed on them or which are goals? +data OnlyConstrained + = OnlyConstrainedNone + | OnlyConstrainedAll + deriving (Eq, Generic, Show) + newtype EnableBackjumping = EnableBackjumping Bool deriving (BooleanFlag, Eq, Generic, Show) @@ -46,8 +63,21 @@ instance Binary ReorderGoals instance Binary CountConflicts instance Binary IndependentGoals +instance Binary MinimizeConflictSet instance Binary AvoidReinstalls instance Binary ShadowPkgs instance Binary StrongFlags instance Binary AllowBootLibInstalls +instance Binary OnlyConstrained instance Binary SolveExecutables + +instance Pretty OnlyConstrained where + pretty OnlyConstrainedAll = PP.text "all" + pretty OnlyConstrainedNone = PP.text "none" + +instance Text OnlyConstrained where + parse = Parse.choice + [ Parse.string "all" >> return OnlyConstrainedAll + , Parse.string "none" >> return OnlyConstrainedNone + ] + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -73,7 +73,7 @@ the setting in the config file; for example, you could use the following: - symlink-bindir: $HOME/bin + installdir: $HOME/bin Quick start on Windows systems diff --git a/bash-completion/cabal b/bash-completion/cabal --- a/bash-completion/cabal +++ b/bash-completion/cabal @@ -1,45 +1,185 @@ +#!/bin/bash + +################################################## + # cabal command line completion +# # Copyright 2007-2008 "Lennart Kolmodin" -# "Duncan Coutts" +# "Duncan Coutts" +# Copyright 2019- "Sam Boosalis" # +# Compatibility — Bash 3. +# +# OSX won't update Bash 3 (last updated circa 2009) to Bash 4, +# and we'd like this completion script to work on both Linux and Mac. +# +# For example, OSX Yosemite (released circa 2014) ships with Bash 3: +# +# $ echo $BASH_VERSION +# 3.2 +# +# While Ubuntu LTS 14.04 (a.k.a. Trusty, also released circa 2016) +# ships with the latest version, Bash 4 (updated circa 2016): +# +# $ echo $BASH_VERSION +# 4.3 +# + +# Testing +# +# (1) Invoke « shellcheck » +# +# * source: « https://github.com/koalaman/shellcheck » +# * run: « shellcheck ./cabal-install/bash-completion/cabal » +# +# (2) Interpret via Bash 3 +# +# * source: « https://ftp.gnu.org/gnu/bash/bash-3.2.tar.gz » +# * run: « bash --noprofile --norc --posix ./cabal-install/bash-completion/cabal » +# +# + +################################################## +# Dependencies: + +command -v cabal >/dev/null +command -v grep >/dev/null +command -v sed >/dev/null + +################################################## + +# List project-specific (/ internal) packages: +# +# + +function _cabal_list_packages () +( + shopt -s nullglob + + local CabalFiles + CabalFiles=( ./*.cabal ./*/*.cabal ./*/*/*.cabal ) + + for FILE in "${CabalFiles[@]}" + do + + BASENAME=$(basename "$FILE") + PACKAGE="${BASENAME%.cabal}" + + echo "$PACKAGE" + + done | sort | uniq +) + +# NOTES +# +# [1] « "${string%suffix}" » strips « suffix » from « string », +# in pure Bash. +# +# [2] « done | sort | uniq » removes duplicates from the output of the for-loop. +# + +################################################## + # List cabal targets by type, pass: -# - test-suite for test suites -# - benchmark for benchmarks -# - executable for executables -# - executable|test-suite|benchmark for the three -_cabal_list() -{ - for f in ./*.cabal; do - grep -Ei "^[[:space:]]*($1)[[:space:]]" "$f" | - sed -e "s/.* \([^ ]*\).*/\1/" - done -} +# +# - ‹test-suite› for test suites +# - ‹benchmark› for benchmarks +# - ‹executable› for executables +# - ‹library› for internal libraries +# - ‹foreign-library› for foreign libraries +# - nothing for all components. +# +function _cabal_list_targets () +( + shopt -s nullglob + + # ^ NOTE « _cabal_list_targets » must be a subshell to temporarily enable « nullglob ». + # hence, « function _ () ( ... ) » over « function _ () { ... } ». + # without « nullglob », if a glob-pattern fails, it becomes a literal + # (i.e. the string with an asterix, rather than an empty string). + + CabalComponent=${1:-library|executable|test-suite|benchmark|foreign-library} + + local CabalFiles + CabalFiles=( ./*.cabal ./*/*.cabal ./*/*/*.cabal ) + + for FILE in "${CabalFiles[@]}" + do + + grep -E -i "^[[:space:]]*($CabalComponent)[[:space:]]" "$FILE" 2>/dev/null | sed -e "s/.* \([^ ]*\).*/\1/" | sed -e '/^$/d' + + done | sort | uniq +) + +# NOTES +# +# [1] in « sed '/^$/d' »: +# +# * « d » is the sed command to delete a line. +# * « ^$ » is a regular expression matching only a blank line +# (i.e. a line start followed by a line end). +# +# dropping blank lines is necessary to ignore public « library » stanzas, +# while still matching private « library _ » stanzas. +# +# [2] +# + +#TODO# rm duplicate components and qualify with « PACKAGE: » (from basename): +# +# $ .. | sort | uniq + +################################################## + # List possible targets depending on the command supplied as parameter. The # ideal option would be to implement this via --list-options on cabal directly. # This is a temporary workaround. -_cabal_targets() + +function _cabal_targets () + { - # If command ($*) contains build, repl, test or bench completes with - # targets of according type. - local comp - for comp in "$@"; do - [ "$comp" == new-build ] && _cabal_list "executable|test-suite|benchmark" && break - [ "$comp" == build ] && _cabal_list "executable|test-suite|benchmark" && break - [ "$comp" == repl ] && _cabal_list "executable|test-suite|benchmark" && break - [ "$comp" == run ] && _cabal_list "executable" && break - [ "$comp" == test ] && _cabal_list "test-suite" && break - [ "$comp" == bench ] && _cabal_list "benchmark" && break + local Completion + + for Completion in "$@"; do + + [ "$Completion" == new-build ] && _cabal_list_targets && break + [ "$Completion" == new-repl ] && _cabal_list_targets && break + [ "$Completion" == new-run ] && _cabal_list_targets "executable" && break + [ "$Completion" == new-test ] && _cabal_list_targets "test-suite" && break + [ "$Completion" == new-bench ] && _cabal_list_targets "benchmark" && break + [ "$Completion" == new-haddock ] && _cabal_list_targets && break + + [ "$Completion" == new-install ] && _cabal_list_targets "executable" && break + # ^ Only complete for local packages (not all 1000s of remote packages). + + [ "$Completion" == build ] && _cabal_list_targets "executable|test-suite|benchmark" && break + [ "$Completion" == repl ] && _cabal_list_targets "executable|test-suite|benchmark" && break + [ "$Completion" == run ] && _cabal_list_targets "executable" && break + [ "$Completion" == test ] && _cabal_list_targets "test-suite" && break + [ "$Completion" == bench ] && _cabal_list_targets "benchmark" && break + done } +# NOTES +# +# [1] « $@ » will be the full command-line (so far). +# +# [2] +# + +################################################## + # List possible subcommands of a cabal subcommand. # # In example "sandbox" is a cabal subcommand that itself has subcommands. Since # "cabal --list-options" doesn't work in such cases we have to get the list # using other means. -_cabal_subcommands() + +function _cabal_subcommands () + { local word for word in "$@"; do @@ -54,7 +194,10 @@ done } -__cabal_has_doubledash () +################################################## + +function __cabal_has_doubledash () + { local c=1 # Ignore the last word, because it is replaced anyways. @@ -70,25 +213,34 @@ return 1 } -_cabal() + +################################################## + +function _cabal () + { # no completion past cabal arguments. __cabal_has_doubledash && return # get the word currently being completed - local cur - cur=${COMP_WORDS[$COMP_CWORD]} + local CurrentWord + CurrentWord=${COMP_WORDS[$COMP_CWORD]} # create a command line to run - local cmd + local CommandLine # copy all words the user has entered - cmd=( ${COMP_WORDS[@]} ) + CommandLine=( "${COMP_WORDS[@]}" ) # replace the current word with --list-options - cmd[${COMP_CWORD}]="--list-options" + CommandLine[${COMP_CWORD}]="--list-options" # the resulting completions should be put into this array - COMPREPLY=( $( compgen -W "$( eval "${cmd[@]}" 2>/dev/null ) $( _cabal_targets "${cmd[@]}" ) $( _cabal_subcommands "${COMP_WORDS[@]}" )" -- "$cur" ) ) + COMPREPLY=( $( compgen -W "$( eval "${CommandLine[@]}" 2>/dev/null ) $( _cabal_targets "${CommandLine[@]}" ) $( _cabal_subcommands "${COMP_WORDS[@]}" )" -- "$CurrentWord" ) ) } + +# abc="a b c" +# { IFS=" " read -a ExampleArray <<< "$abc"; echo ${ExampleArray[@]}; echo ${!ExampleArray[@]}; } + +################################################## complete -F _cabal -o default cabal diff --git a/bootstrap.sh b/bootstrap.sh --- a/bootstrap.sh +++ b/bootstrap.sh @@ -34,7 +34,7 @@ GZIP_PROGRAM="${GZIP_PROGRAM:-gzip}" # The variable SCOPE_OF_INSTALLATION can be set on the command line to -# use/install the libaries needed to build cabal-install to a custom package +# use/install the libraries needed to build cabal-install to a custom package # database instead of the user or global package database. # # Example: @@ -137,6 +137,9 @@ "--no-doc") NO_DOCUMENTATION=1 shift;; + "--no-install") + NO_INSTALL=1 + shift;; "-j"|"--jobs") shift # check if there is another argument which doesn't start with - or -- @@ -221,8 +224,8 @@ # >= 2.6.0.2 && < 2.7 NETWORK_VER="2.7.0.0"; NETWORK_VER_REGEXP="2\.[0-7]\." # >= 2.0 && < 2.7 -CABAL_VER="2.4.1.0"; CABAL_VER_REGEXP="2\.4\.[1-9]" - # >= 2.4.1.0 && < 2.5 +CABAL_VER="3.0.0.0"; CABAL_VER_REGEXP="3\.0\.[0-9]" + # >= 2.5 && < 2.6 TRANS_VER="0.5.5.0"; TRANS_VER_REGEXP="0\.[45]\." # >= 0.2.* && < 0.6 MTL_VER="2.2.2"; MTL_VER_REGEXP="[2]\." @@ -276,6 +279,7 @@ echo "Checking installed packages for ghc-${GHC_VER}..." ${GHC_PKG} list --global ${SCOPE_OF_INSTALLATION} > ghc-pkg.list || die "running '${GHC_PKG} list' failed" +trap "rm ghc-pkg.list" EXIT # Will we need to install this package, or is a suitable version installed? need_pkg () { @@ -297,11 +301,14 @@ if need_pkg ${PKG} ${VER_MATCH} then - if [ -r "${PKG}-${VER}.tar.gz" ] + if [ -d "${PKG}-${VER}" ] then - echo "${PKG}-${VER} will be installed from local tarball." + echo "${PKG}-${VER} will be installed from local directory." + elif [ -r "${PKG}-${VER}.tar.gz" ] + then + echo "${PKG}-${VER} will be installed from local tarball." else - echo "${PKG}-${VER} will be downloaded and installed." + echo "${PKG}-${VER} will be downloaded and installed." fi else echo "${PKG} is already installed and the version is ok." @@ -348,6 +355,8 @@ } install_pkg () { + [ ${NO_INSTALL} ] && return 0 + PKG=$1 VER=$2 @@ -397,14 +406,19 @@ if need_pkg ${PKG} ${VER_MATCH} then echo - if [ -r "${PKG}-${VER}.tar.gz" ] + if [ -d "${PKG}-${VER}" ] then - echo "Using local tarball for ${PKG}-${VER}." + echo "Using local directory for ${PKG}-${VER}." else + if [ -r "${PKG}-${VER}.tar.gz" ] + then + echo "Using local tarball for ${PKG}-${VER}." + else echo "Downloading ${PKG}-${VER}..." fetch_pkg ${PKG} ${VER} + fi + unpack_pkg "${PKG}" "${VER}" fi - unpack_pkg "${PKG}" "${VER}" (cd "${PKG}-${VER}" && install_pkg ${PKG} ${VER}) fi } @@ -501,12 +515,13 @@ install_pkg "cabal-install" +[ ${NO_INSTALL} ] && exit 0 # Use the newly built cabal to turn the prefix/package database into a # legit cabal sandbox. This works because 'cabal sandbox init' will # reuse the already existing package database and other files if they # are in the expected locations. -[ ! -z "$SANDBOX" ] && $SANDBOX/bin/cabal sandbox init --sandbox $SANDBOX +[ ! -z "$SANDBOX" ] && $SANDBOX/bin/cabal v1-sandbox init --sandbox $SANDBOX echo echo "===========================================" @@ -525,12 +540,10 @@ echo "By default cabal will install programs to $HOME/.cabal/bin" echo "If you do not want to add this directory to your PATH then you can" echo "change the setting in the config file, for example you could use:" - echo "symlink-bindir: $HOME/bin" + echo "installdir: $HOME/bin" else echo "Sorry, something went wrong." echo "The 'cabal' executable was not successfully installed into" echo "$CABAL_BIN/" fi echo - -rm ghc-pkg.list diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -4,7 +4,7 @@ -- To update this file, edit 'cabal-install.cabal.pp' and run -- 'make cabal-install-prod' in the project's root folder. Name: cabal-install -Version: 2.4.1.0 +Version: 3.0.0.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing @@ -16,7 +16,7 @@ License-File: LICENSE Author: Cabal Development Team (see AUTHORS file) Maintainer: Cabal Development Team -Copyright: 2003-2018, Cabal Development Team +Copyright: 2003-2019, Cabal Development Team Category: Distribution Build-type: Custom Extra-Source-Files: @@ -146,6 +146,13 @@ extra-libraries: bsd hs-source-dirs: . other-modules: + -- this modules are moved from Cabal + -- they are needed for as long until cabal-install moves to parsec parser + Distribution.Deprecated.ParseUtils + Distribution.Deprecated.ReadP + Distribution.Deprecated.Text + Distribution.Deprecated.ViewAsFieldDescr + Distribution.Client.BuildReports.Anonymous Distribution.Client.BuildReports.Storage Distribution.Client.BuildReports.Types @@ -161,6 +168,7 @@ Distribution.Client.CmdFreeze Distribution.Client.CmdHaddock Distribution.Client.CmdInstall + Distribution.Client.CmdInstall.ClientInstallFlags Distribution.Client.CmdRepl Distribution.Client.CmdRun Distribution.Client.CmdTest @@ -243,6 +251,7 @@ Distribution.Client.Utils Distribution.Client.Utils.Assertion Distribution.Client.Utils.Json + Distribution.Client.Utils.Parsec Distribution.Client.VCS Distribution.Client.Win32SelfUpgrade Distribution.Client.World @@ -303,7 +312,7 @@ base16-bytestring >= 0.1.1 && < 0.2, binary >= 0.7.3 && < 0.9, bytestring >= 0.10.6.0 && < 0.11, - Cabal >= 2.4.1.0 && < 2.5, + Cabal == 3.0.*, containers >= 0.5.6.2 && < 0.7, cryptohash-sha256 >= 0.11 && < 0.12, deepseq >= 1.4.1.1 && < 1.5, @@ -311,11 +320,11 @@ echo >= 0.1.3 && < 0.2, edit-distance >= 0.2.2 && < 0.3, filepath >= 1.4.0.0 && < 1.5, - hashable >= 1.0 && < 1.3, + hashable >= 1.0 && < 1.4, HTTP >= 4000.1.5 && < 4000.4, mtl >= 2.0 && < 2.3, network-uri >= 2.6.0.2 && < 2.7, - network >= 2.6 && < 2.9, + network >= 2.6 && < 3.2, pretty >= 1.1 && < 1.2, process >= 1.2.3.0 && < 1.7, random >= 1 && < 1.2, @@ -325,9 +334,11 @@ zlib >= 0.5.3 && < 0.7, hackage-security >= 0.5.2.2 && < 0.6, text >= 1.2.3 && < 1.3, - zip-archive >= 0.3.2.5 && < 0.4, parsec >= 3.1.13.0 && < 3.2 + if !impl(ghc >= 8.0) + build-depends: fail == 4.9.* + if flag(native-dns) if os(windows) build-depends: windns >= 0.1.0 && < 0.2 @@ -337,7 +348,7 @@ if os(windows) build-depends: Win32 >= 2 && < 3 else - build-depends: unix >= 2.5 && < 2.8 + build-depends: unix >= 2.5 && < 2.9 if flag(debug-expensive-assertions) cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,46 @@ -*-change-log-*- +3.0.0.0 Mikhail Glushenkov August 2019 + * `v2-haddock` fails on `haddock` failures (#5977) + * `v2-run` works when given `File.lhs` literate file. (#6134) + * Parse comma-seperated lists for extra-prog-path, extra-lib-dirs, extra-framework-dirs, + and extra-include-dirs as actual lists. (#5420) + * `v2-repl` no longer changes directory to a randomized temporary folder + when used outside of a project. (#5544) + * `install-method` and `overwrite-policy` in `.cabal/config` now actually work. (#5942) + * `v2-install` now reports the error when a package fails to build. (#5641) + * `v2-install` now has a default when called in a project (#5978, #6014, #6092) + * '--write-ghc-environment-files' now defaults to 'never' (#4242) + * Fix `sdist`'s output when sent to stdout. (#5874) + * Allow a list of dependencies to be provided for `repl --build-depends`. (#5845) + * Legacy commands are now only accessible with the `v1-` prefixes, and the `v2-` + commands are the new default. Accordingly, the next version of Cabal will be + the start of the 3.x version series. (#5800) + * New solver flag: '--reject-unconstrained-dependencies'. (#2568) + * Ported old-style test options to the new-style commands (#5455). + * Improved error messages for cabal file parse errors. (#5710) + * Removed support for `.zip` format source distributions (#5755) + * Add "simple project" initialization option. (#5707) + * Add '--minimize-conflict-set' flag to try to improve the solver's + error message, but with an increase in run time. (#5647) + * v2-test now succeeds when there are no test suites. (#5435) + * Add '--lib', '--exe', and '--libandexe' shorthands to init. (#5759) + * init now generates valid `Main.lhs` files. (#5577) + * Init improvements: add flag '--application-dir', and when creating + a library also create a MyLib.hs module. (#5740) + * Add support for generating test-suite via cabal init. (#5761) + * Increase `max-backjumps` default from 2000 to 4000. + * Make v2-install/new-install-specific flags configurable in + ~/.cabal/config + * Add --installdir and --install-method=copy flags to v2-install + that make it possible to copy the executable instead of symlinking it + * --symlink-bindir no longer controls the symlinking directory of + v2-install (installdir controls both symlinking and copying now) + * Default to non-interactive init. + * Add --test-wrapper that allows a prebuild script to set the test environment. + * Add filterTestFlags: filter test-wrapper for Cabal < 3.0.0. + * Cabal now only builds the minimum of a package for `v2-install` (#5754, #6091) + 2.4.1.0 Mikhail Glushenkov November 2018 * Add message to alert user to potential package casing errors. (#5635) * new-clean no longer deletes dist-newstyle/src with `-s`. (#5699) @@ -11,9 +52,9 @@ * Register monolithic packages installed into the store due to a build-tool dependency if they also happen to contain a buildable public lib. (#5379,#5604) - * Fixed a Windows bug where cabal-install tried to copy files - after moving them (#5631). - * 'cabal v2-repl' now works for indefinite (in the Backpack sense) components. (#5619) + * Fixed a Windows bug where cabal-install tried to copy files + after moving them (#5631). + * 'cabal v2-repl' now works for indefinite (in the Backpack sense) components. (#5619) * Set data dir environment variable for tarballs and remote repos (#5469) * Fix monolithic inplace build tool PATH (#5633) * 'cabal init' now supports '-w'/'--with-compiler' flag (#4936, #5654) @@ -148,7 +189,7 @@ * Paths_ autogen modules now compile when `RebindableSyntax` or `OverloadedStrings` is used in `default-extensions`. [stack#3789](https://github.com/commercialhaskell/stack/issues/3789) - * `getDataDir` and other `Paths_autogen` functions now work correctly + * getDataDir` and other `Paths_autogen` functions now work correctly when compiling a custom `Setup.hs` script using `new-build` (#5164). 2.0.0.1 Mikhail Glushenkov December 2017 diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -39,7 +39,7 @@ , ReportFlags(..), reportCommand , runCommand , InitFlags(initVerbosity, initHcPath), initCommand - , SDistFlags(..), SDistExFlags(..), sdistCommand + , SDistFlags(..), sdistCommand , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand , ActAsSetupFlags(..), actAsSetupCommand , SandboxFlags(..), sandboxCommand @@ -80,7 +80,6 @@ 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 @@ -142,9 +141,7 @@ import Distribution.Client.Manpage (manpage) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import Distribution.Client.Utils (determineNumJobs -#if defined(mingw32_HOST_OS) ,relaxEncodingErrors -#endif ) import Distribution.Package (packageId) @@ -186,19 +183,18 @@ ( Version, mkVersion, orLaterVersion ) import qualified Paths_cabal_install (version) +import Distribution.Compat.ResponseFile import System.Environment (getArgs, getProgName) import System.Exit (exitFailure, exitSuccess) import System.FilePath ( dropExtension, splitExtension - , takeExtension, (), (<.>)) + , takeExtension, (), (<.>) ) import System.IO ( BufferMode(LineBuffering), hSetBuffering -#ifdef mingw32_HOST_OS - , stderr -#endif - , stdout ) + , stderr, stdout ) import System.Directory (doesFileExist, getCurrentDirectory) import Data.Monoid (Any(..)) import Control.Exception (SomeException(..), try) import Control.Monad (mapM_) +import Data.Version (showVersion) #ifdef MONOLITHIC import qualified UnitTests @@ -230,21 +226,19 @@ -- 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 - -- The default locale encoding for Windows CLI is not UTF-8 and printing - -- Unicode characters to it will fail unless we relax the handling of encoding - -- errors when writing to stderr and stdout. -#ifdef mingw32_HOST_OS + -- 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 -#endif - getArgs >>= mainWorker + (args0, args1) <- break (== "--") <$> getArgs + mainWorker =<< (++ args1) <$> expandResponse args0 mainWorker :: [String] -> IO () mainWorker args = do - validScript <- - if null args - then return False - else doesFileExist (last args) + hasScript <- if not (null args) + then CmdRun.validScript (head args) + else return False topHandler $ case commandsRun (globalCommand commands) commands args of @@ -259,8 +253,8 @@ -> printNumericVersion CommandHelp help -> printCommandHelp help CommandList opts -> printOptionsList opts - CommandErrors errs - | validScript -> CmdRun.handleShebang (last args) + CommandErrors errs + | hasScript -> CmdRun.handleShebang (head args) (tail args) | otherwise -> printErrors errs CommandReadyToGo action -> do globalFlags' <- updateSandboxConfigFileFlag globalFlags @@ -282,9 +276,9 @@ ++ "defaults if you run 'cabal update'." printOptionsList = putStr . unlines printErrors errs = dieNoVerbosity $ intercalate "\n" errs - printNumericVersion = putStrLn $ display Paths_cabal_install.version + printNumericVersion = putStrLn $ showVersion Paths_cabal_install.version printVersion = putStrLn $ "cabal-install version " - ++ display Paths_cabal_install.version + ++ showVersion Paths_cabal_install.version ++ "\ncompiled using version " ++ display cabalVersion ++ " of the Cabal library " @@ -323,9 +317,9 @@ , newCmd CmdTest.testCommand CmdTest.testAction , newCmd CmdBench.benchCommand CmdBench.benchAction , newCmd CmdExec.execCommand CmdExec.execAction - , newCmd CmdClean.cleanCommand CmdClean.cleanAction + , newCmd CmdClean.cleanCommand CmdClean.cleanAction , newCmd CmdSdist.sdistCommand CmdSdist.sdistAction - + , legacyCmd configureExCommand configureAction , legacyCmd updateCommand updateAction , legacyCmd buildCommand buildAction @@ -560,9 +554,9 @@ either (const onNoPkgDesc) (const onPkgDesc) pkgDesc -installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) -> [String] -> Action -installAction (configFlags, _, installFlags, _) _ globalFlags +installAction (configFlags, _, installFlags, _, _) _ globalFlags | fromFlagOrDefault False (installOnly installFlags) = do let verb = fromFlagOrDefault normal (configVerbosity configFlags) (useSandbox, config) <- loadConfigOrSandboxConfig verb globalFlags @@ -574,7 +568,7 @@ installCommand (const mempty) (const []) installAction - (configFlags, configExFlags, installFlags, haddockFlags) + (configFlags, configExFlags, installFlags, haddockFlags, testFlags) extraArgs globalFlags = do let verb = fromFlagOrDefault normal (configVerbosity configFlags) (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) @@ -593,7 +587,7 @@ -- TODO: It'd be nice if 'cabal install' picked up the '-w' flag passed to -- 'configure' when run inside a sandbox. Right now, running -- - -- $ cabal sandbox init && cabal configure -w /path/to/ghc + -- \$ cabal sandbox init && cabal configure -w /path/to/ghc -- && cabal build && cabal install -- -- performs the compilation twice unless you also pass -w to 'install'. @@ -610,6 +604,9 @@ haddockFlags' = defaultHaddockFlags `mappend` savedHaddockFlags config `mappend` haddockFlags { haddockDistPref = toFlag dist } + testFlags' = Cabal.defaultTestFlags `mappend` + savedTestFlags config `mappend` + testFlags { testDistPref = toFlag dist } globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, progdb) <- configCompilerAux' configFlags' -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the @@ -646,7 +643,7 @@ comp platform progdb' useSandbox mSandboxPkgInfo globalFlags' configFlags'' configExFlags' - installFlags' haddockFlags' + installFlags' haddockFlags' testFlags' targets where @@ -888,9 +885,9 @@ withRepoContext verbosity globalFlags' $ \repoContext -> update verbosity updateFlags repoContext -upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) -> [String] -> Action -upgradeAction (configFlags, _, _, _) _ _ = die' verbosity $ +upgradeAction (configFlags, _, _, _, _) _ _ = die' verbosity $ "Use the 'cabal install' command instead of 'cabal upgrade'.\n" ++ "You can install the latest version of a package using 'cabal install'. " ++ "The 'cabal upgrade' command has been removed because people found it " @@ -1051,7 +1048,7 @@ let verbosity = fromFlag verbosityFlag path <- case extraArgs of [] -> do cwd <- getCurrentDirectory - tryFindPackageDesc cwd + tryFindPackageDesc verbosity cwd (p:_) -> return p pkgDesc <- readGenericPackageDescription verbosity path -- Uses 'writeFileAtomic' under the hood. @@ -1070,16 +1067,15 @@ ++ package ++ "' or 'cabal sandbox hc-pkg -- unregister " ++ package ++ "'." -sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> Action -sdistAction (sdistFlags, sdistExFlags) extraArgs globalFlags = do +sdistAction :: SDistFlags -> [String] -> Action +sdistAction sdistFlags extraArgs globalFlags = do let verbosity = fromFlag (sDistVerbosity sdistFlags) unless (null extraArgs) $ die' verbosity $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs load <- try (loadConfigOrSandboxConfig verbosity globalFlags) let config = either (\(SomeException _) -> mempty) snd load distPref <- findSavedDistPref config (sDistDistPref sdistFlags) - let sdistFlags' = sdistFlags { sDistDistPref = toFlag distPref } - sdist sdistFlags' sdistExFlags + sdist sdistFlags { sDistDistPref = toFlag distPref } reportAction :: ReportFlags -> [String] -> Action reportAction reportFlags extraArgs globalFlags = do @@ -1146,6 +1142,7 @@ let configFlags = savedConfigureFlags config `mappend` -- override with `--with-compiler` from CLI if available mempty { configHcPath = initHcPath initFlags } + let initFlags' = savedInitFlags config `mappend` initFlags let globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, _, progdb) <- configCompilerAux' configFlags withRepoContext verbosity globalFlags' $ \repoContext -> @@ -1154,7 +1151,7 @@ repoContext comp progdb - initFlags + initFlags' sandboxAction :: SandboxFlags -> [String] -> Action sandboxAction sandboxFlags extraArgs globalFlags = do @@ -1225,7 +1222,7 @@ win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags) - Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path -- TODO: eradicateNoParse + Win32SelfUpgrade.deleteOldExeFile verbosity (fromMaybe (error $ "panic! read pid=" ++ show pid) $ readMaybe pid) path -- TODO: eradicateNoParse win32SelfUpgradeAction _ _ _ = return () -- | Used as an entry point when cabal-install needs to invoke itself