packages feed

cabal-install 2.4.1.0 → 3.0.0.0

raw patch · 104 files changed

+5158/−1846 lines, 104 filesdep +faildep −zip-archivedep ~Cabaldep ~Win32dep ~unix

Dependencies added: fail

Dependencies removed: zip-archive

Dependency ranges changed: Cabal, Win32, unix

Files

Distribution/Client/BuildReports/Anonymous.hs view
@@ -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 )
Distribution/Client/BuildReports/Types.hs view
@@ -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 )
Distribution/Client/BuildReports/Upload.hs view
@@ -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
Distribution/Client/Check.hs view
@@ -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
Distribution/Client/CmdBench.hs view
@@ -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,
Distribution/Client/CmdBuild.hs view
@@ -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]
Distribution/Client/CmdClean.hs view
@@ -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"
Distribution/Client/CmdConfigure.hs view
@@ -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
Distribution/Client/CmdErrorMessages.hs view
@@ -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
Distribution/Client/CmdExec.hs view
@@ -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}
Distribution/Client/CmdFreeze.hs view
@@ -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
Distribution/Client/CmdHaddock.hs view
@@ -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
Distribution/Client/CmdInstall.hs view
@@ -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=<path>"-      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=<path>"+  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
+ Distribution/Client/CmdInstall/ClientInstallFlags.hs view
@@ -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                      = []+
Distribution/Client/CmdLegacy.hs view
@@ -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             }
Distribution/Client/CmdRepl.hs view
@@ -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
Distribution/Client/CmdRun.hs view
@@ -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]
Distribution/Client/CmdSdist.hs view
@@ -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."-
Distribution/Client/CmdTest.hs view
@@ -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
Distribution/Client/CmdUpdate.hs view
@@ -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 <repo-id>[,<index-state>] 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"
Distribution/Client/Compat/Prelude.hs view
@@ -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 )
Distribution/Client/Config.hs view
@@ -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)]]
Distribution/Client/Configure.hs view
@@ -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,
Distribution/Client/Dependency.hs view
@@ -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 _
Distribution/Client/Dependency/Types.hs view
@@ -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
Distribution/Client/DistDirLayout.hs view
@@ -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"
Distribution/Client/Fetch.hs view
@@ -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 ()
Distribution/Client/FetchUtils.hs view
@@ -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 )
Distribution/Client/Freeze.hs view
@@ -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.
Distribution/Client/GenBounds.hs view
@@ -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.
Distribution/Client/Get.hs view
@@ -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."
Distribution/Client/Glob.hs view
@@ -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
Distribution/Client/HttpUtils.hs view
@@ -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
Distribution/Client/IndexUtils.hs view
@@ -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
Distribution/Client/IndexUtils/Timestamp.hs view
@@ -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
Distribution/Client/Init.hs view
@@ -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 ()
Distribution/Client/Init/Heuristics.hs view
@@ -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
Distribution/Client/Init/Types.hs view
@@ -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-
Distribution/Client/Install.hs view
@@ -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
Distribution/Client/InstallPlan.hs view
@@ -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,
Distribution/Client/InstallSymlink.hs view
@@ -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
Distribution/Client/List.hs view
@@ -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
Distribution/Client/Outdated.hs view
@@ -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
Distribution/Client/PackageHash.hs view
@@ -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
Distribution/Client/PackageUtils.hs view
@@ -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)
Distribution/Client/ParseUtils.hs view
@@ -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
Distribution/Client/ProjectBuilding.hs view
@@ -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
Distribution/Client/ProjectConfig.hs view
@@ -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,
Distribution/Client/ProjectConfig/Legacy.hs view
@@ -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]
Distribution/Client/ProjectConfig/Types.hs view
@@ -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
Distribution/Client/ProjectOrchestration.hs view
@@ -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
Distribution/Client/ProjectPlanOutput.hs view
@@ -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
Distribution/Client/ProjectPlanning.hs view
@@ -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,
Distribution/Client/ProjectPlanning/Types.hs view
@@ -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
Distribution/Client/Run.hs view
@@ -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
Distribution/Client/Sandbox.hs view
@@ -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
Distribution/Client/Sandbox/PackageEnvironment.hs view
@@ -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 )
Distribution/Client/Sandbox/Timestamp.hs view
@@ -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)
Distribution/Client/Security/HTTP.hs view
@@ -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
Distribution/Client/Setup.hs view
@@ -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 --<enable|disable>-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 ++ ":"
Distribution/Client/SetupWrapper.hs view
@@ -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)
Distribution/Client/SolverInstallPlan.hs view
@@ -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
Distribution/Client/SourceRepoParse.hs view
@@ -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
Distribution/Client/SrcDist.hs view
@@ -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).
Distribution/Client/Store.hs view
@@ -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
Distribution/Client/TargetSelector.hs view
@@ -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
Distribution/Client/Targets.hs view
@@ -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
Distribution/Client/Types.hs view
@@ -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
Distribution/Client/Update.hs view
@@ -33,7 +33,7 @@          ( newParallelJobControl, spawnJob, collectJob ) import Distribution.Client.Setup          ( RepoContext(..), UpdateFlags(..) )-import Distribution.Text+import Distribution.Deprecated.Text          ( display ) import Distribution.Verbosity
Distribution/Client/Upload.hs view
@@ -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 <pkgid>-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 ()
+ Distribution/Client/Utils/Parsec.hs view
@@ -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'
Distribution/Client/World.hs view
@@ -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
+ Distribution/Deprecated/ParseUtils.hs view
@@ -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 @<property>: <value>@ field+    | Section LineNo String String [Field]+      -- ^ A section with a name and possible parameter.  The syntactic+      -- structure is:+      --+      -- @+      --   <sectionname> <arg> {+      --     <field>*+      --   }+      -- @+    | IfBlock LineNo String [Field] [Field]+      -- ^ A conditional block with an optional else branch:+      --+      -- @+      --  if <condition> {+      --    <field>*+      --  } else {+      --    <field>*+      --  }+      -- @+      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
+ Distribution/Deprecated/ReadP.hs view
@@ -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/+-- (<http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.19.9217>).+--+-- This version of ReadP has been locally hacked to make it H98, by+-- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>+--+-- The unit tests have been moved to UnitTest.Distribution.Deprecated.ReadP, by+-- Mark Lentczner <mailto:mark@glyphic.com>+-----------------------------------------------------------------------------++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
+ Distribution/Deprecated/Text.hs view
@@ -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
+ Distribution/Deprecated/ViewAsFieldDescr.hs view
@@ -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 ("<viewAsFieldDescr>" ++) 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"++
Distribution/Solver/Compat/Prelude.hs view
@@ -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. --
Distribution/Solver/Modular.hs view
@@ -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  = ""
Distribution/Solver/Modular/Builder.hs view
@@ -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)))
Distribution/Solver/Modular/ConflictSet.hs view
@@ -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
Distribution/Solver/Modular/Dependency.hs view
@@ -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
Distribution/Solver/Modular/Explore.hs view
@@ -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
Distribution/Solver/Modular/IndexConversion.hs view
@@ -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
Distribution/Solver/Modular/Log.hs view
@@ -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
Distribution/Solver/Modular/Message.hs view
@@ -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.
Distribution/Solver/Modular/Package.hs view
@@ -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
Distribution/Solver/Modular/Preference.hs view
@@ -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
Distribution/Solver/Modular/Solver.hs view
@@ -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
Distribution/Solver/Modular/Tree.hs view
@@ -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
Distribution/Solver/Modular/Validate.hs view
@@ -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
Distribution/Solver/Modular/Version.hs view
@@ -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
Distribution/Solver/Types/ComponentDeps.hs view
@@ -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
Distribution/Solver/Types/InstSolverPackage.hs view
@@ -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
Distribution/Solver/Types/PackageConstraint.hs view
@@ -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
Distribution/Solver/Types/PackageIndex.hs view
@@ -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 ]
Distribution/Solver/Types/PackagePath.hs view
@@ -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 ((<<>>))
Distribution/Solver/Types/PkgConfigDb.hs view
@@ -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
Distribution/Solver/Types/Settings.hs view
@@ -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+    ]+
README.md view
@@ -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
bash-completion/cabal view
@@ -1,45 +1,185 @@+#!/bin/bash++##################################################+ # cabal command line completion+# # Copyright 2007-2008 "Lennart Kolmodin" <kolmodin@gentoo.org>-#                     "Duncan Coutts"     <dcoutts@gentoo.org>+#                     "Duncan Coutts"    <dcoutts@gentoo.org>+# Copyright 2019-     "Sam Boosalis"     <samboosalis@gmail.com> # +# 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
bootstrap.sh view
@@ -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
cabal-install.cabal view
@@ -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 <cabal-devel@haskell.org>-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
changelog view
@@ -1,5 +1,46 @@ -*-change-log-*- +3.0.0.0 Mikhail Glushenkov <mikhail.glushenkov@gmail.com> 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 <mikhail.glushenkov@gmail.com> 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 <mikhail.glushenkov@gmail.com> December 2017
main/Main.hs view
@@ -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